请langs大师帮帮忙。

xiaodao520

要求增加将周长和面积标注到图形中功能，如L= ****mm,S=*****mm2，同时输出到EXCEL中。

以下代码来自：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=92023

;;; 框选封闭区域面积到excel   
;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
(defun c:qq (/ appxls col ent ent1 ent2 f i lst lst1 m2 maxpoint minpoint na
        newbook newitem newsheet numrow pc pmax pmin pt sc snap ss
        txt value vh viewsize vw x xlscells xlsworkbooks y
     )
  (defun GetViewSize (/ pc vh sc vw vh pmin pmax)
    (setq pc (getvar "viewctr")
   vh (getvar "viewsize")
   sc (getvar "screensize")
   vw (* vh (/ (car sc) (cadr sc)))
   pmin (list (- (car pc) (* 0.5 vw)) (- (cadr pc) (* 0.5 vh)))
   pmax (list (+ (car pc) (* 0.5 vw)) (+ (cadr pc) (* 0.5 vh)))
    )
    (list pmin pmax)
  )
  (defun initexcel ()
    (setq appxls (vlax-get-or-create-object "excel.application")
   xlsworkbooks (vlax-get-property appxls "workbooks")
   newbook (vlax-invoke-method xlsworkbooks "add")
   newsheet (vlax-get-property newbook "sheets")
   newitem (vlax-get-property newsheet "item" 1)
   xlscells (vlax-get-property newitem "cells")
    )
    (vla-put-visible appxls :vlax-true)
  )
  (defun endexcel ()
    (vlax-release-object xlscells)
    (vlax-release-object newitem)
    (vlax-release-object newsheet)
    (vlax-release-object newbook)
    (vlax-release-object xlsworkbooks)
    (vlax-release-object appxls)
  )
  (defun datacell (nurow col value)
    (vlax-put-property xlscells "item" numrow col
         (vl-princ-to-string value)
    )
  )
  (vl-load-com)
  (setvar "cmdecho" 0)
  (setq snap (getvar "osmode"))        ; 关闭捕捉
  (setvar "osmode" 0)
  (if (setq ss (ssget '((0 . "*TEXT"))))
    (progn
      (setq ViewSize (GetViewSize))
      (setq lst1 '())
      (repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i))))
       pt (cdr (assoc 10 ent))
       txt (cdr (assoc 1 ent))
)
(command "-boundary" pt "")
(setq ent2 (entlast))
(if (= (cdr (assoc 0 (entget ent2))) "LWPOLYLINE")
   (progn
     (vla-getboundingbox (vlax-ename->vla-object ent2) 'minpoint
    'maxpoint
     )
     (setq pmax (vlax-safearray->list maxpoint)
    pmin (vlax-safearray->list minpoint)
     )
     (entdel ent2)
     (setq lst1 (cons (list pmin pmax pt txt) lst1))
   )
)
      )
      (= lst nil)
      (repeat (setq i (length lst1))
(setq na (nth (setq i (1- i))
        lst1
   )
       pmin (car na)
       pmax (cadr na)
       pt (caddr na)
       txt (cadddr na)
)
(command ".zoom" "W" pmin pmax)
(command "-boundary" pt "")
(command ".region" (entlast) "")
(setq ent1 (entlast))
(if (= (cdr (assoc 0 (entget ent1))) "REGION")
   (setq ent (vlax-ename->vla-object ent1)
  m2 (rtos (vla-get-area ent) 2 2)
  lst (cons (list txt m2) lst)
  f (entdel ent1)
   )
)
      )
      (command ".zoom" "W" (car ViewSize) (cadr ViewSize))
      (setq lst (vl-sort lst (function (lambda (x y)
      (< (car x) (car y))
           )
        )
  )
      )
      (setq lst (cons (list "版号" "面积") lst))
      (initexcel)
      (setq numrow 1)
      (foreach f lst
(datacell numrow 1 (car f))
(datacell numrow 2 (cadr f))
(setq numrow (1+ numrow))
      )
      (endexcel)
    )
  )
  (setvar "osmode" snap)        ; 恢复捕捉
  (princ)
)

xiaodao520

langs哥帮帮忙，

xiaodao520

自己顶下

xiaodao520

没人过问，

langjs

才看到，最近没泡论坛

九日生

区域一多就出问题啦