【源码】面积批量标注

;;;;批量面积标注;;;;2026/7/6(defun c:plmj(/ *acad* *doc* ss i ent obj area dh sc)  (vl-load-com)  (setq *acad*(vlax-get-acad-object)        *doc*(vla-get-activedocument *acad*))  (setq dh 0.5 sc 1)  (if (setq ss (ssget '((0 . "CIRCLE,ELLIPSE,LWPOLYLINE,POLYLINE,REGION"))))    (repeat (setq i (sslength ss))      (setq ent (ssname ss (setq i (1- i)))            obj (vlax-ename->vla-object ent))    (vlax-Invoke-Method obj 'GetBoundingBox 'pa 'pb)          (setq pa (vlax-safearray->list pa)                pb (vlax-safearray->list pb)		pt(mapcar'-(mapcar'(lambda(x)(* 0.5 x))(mapcar'+ pa pb))(list(* dh 4)(* dh 0.5) )))      (if (vlax-property-available-p obj 'Area)        (progn          (setq area(* (vla-get-area obj) (* sc sc)))          (if (vlax-curve-isclosed ent)            (progn              (make_text pt (strcat "面积:" (rtos area 2 2) " m2") dh 0)              (princ (strcat "\n标注面积:" (rtos area 2 2) " m2")))            (alert "所选对象未闭合！")))        (alert "所选对象无法计算面积！"))))  (princ))(defun make_text (pt txt dh rotation / textStyle layerSel layerObj Txtobj)  (setq textStyle (vla-get-ActiveTextStyle(vla-get-ActiveDocument(vlax-get-acad-object))))  (setq layerSel(vla-get-Layers(vla-get-ActiveDocument (vlax-get-acad-object))))		     (vla-put-height textStyle dh)  (setq layerObj (vla-add layerSel "Area"))  (vla-put-Color layerObj acRed)  (vla-put-height textStyle dh)  (setq Txtobj(vla-AddText		(vla-get-ModelSpace		  (vla-get-ActiveDocument		    (vlax-get-acad-object)))		txt(vlax-3d-point pt)dh))    (vla-put-Rotation Txtobj rotation)  (vla-put-layer Txtobj "Area")  (princ))(prompt "\n输入 \"PLMJ\" 进行面积标注。")