[编程交流] 区域lisp

[/c(defun C:alb (/ acsp adoc ar axss hgt maxp minp obj p1 p2 pc ss txt)
(vl-load-com)
(setq        adoc (vla-get-activedocument
      (vlax-get-acad-object)
    )
)
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark (vla-get-activedocument
                      (vlax-get-acad-object)))
(initget 7)
(setq hgt (getreal "\nEnter text height: "))
 
(prompt "\nSelect objects on screen to add area label")
(if (setq ss (ssget))
(progn
   (setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if (not
(vl-catch-all-error-p
 (setq
   ar (vl-catch-all-apply
          (function (lambda()
                        (vlax-curve-getarea obj)))))))
(progn
(setq txt (strcat "Area = " (rtos ar 2 2)))
(vla-getboundingbox obj 'minp 'maxp)
(setq p1 (vlax-safearray->list minp)
 p2 (vlax-safearray->list maxp)
 pc (mapcar (function (lambda(a b)(/ (+ a b) 2))) p1 p2)
 )
(vlax-invoke acsp 'Addtext txt pc hgt)
)
 )
)
)
)
(vla-endundomark (vla-get-activedocument
                      (vlax-get-acad-object)))
   (princ)
   )
(princ "\nType ALB to label objects with area text")
(princ)

(defun C:alb (/ acsp adoc ar axss hgt maxp minp obj p1 p2 pc1 pc2 per
               ss txt1 txt2)
(vl-load-com)
(setq        adoc (vla-get-activedocument
      (vlax-get-acad-object)
    )
)
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark (vla-get-activedocument
                      (vlax-get-acad-object)))
(initget 7)
(setq hgt (getreal "\n  Enter text height: "))
 
(prompt "\n  Select objects on screen to add area label")
(if (setq ss (ssget))
(progn
   (setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if
(and
(not
(vl-catch-all-error-p
 (setq
   ar (vl-catch-all-apply
          (function (lambda()
                        (vlax-curve-getarea obj)))))))
(not
(vl-catch-all-error-p
   (setq
   per (vl-catch-all-apply
          (function (lambda()
                        (vlax-curve-getdistatparam obj
                             (vlax-curve-getendparam obj)))))))))
(progn
(setq txt1 (strcat "Area = " (rtos ar 2 2)))
(setq txt2 (strcat "Perimeter = " (rtos per 2 2)))
(vla-getboundingbox obj 'minp 'maxp)
(setq p1 (vlax-safearray->list minp)
 p2 (vlax-safearray->list maxp)
 pc1 (mapcar (function (lambda(a b)(/ (+ a b) 2))) p1 p2)
 pc2 (mapcar '- pc1 (list 0 (* hgt 1.5) 0))    
     
 )
(vlax-invoke acsp 'Addtext txt1 pc1 hgt)
(vlax-invoke acsp 'Addtext txt2 pc2 hgt)
)
 )
)
)
)
(vla-endundomark (vla-get-activedocument
                      (vlax-get-acad-object)))
   (princ)
   )
(princ "\n   Type ALB to label objects with area and perimeter text")
(princ)
(C:alb)