計算填充面積并標注 · AutoLISP編程指南

[^-^]:http://bbs.mjtd.com/thread-107008-1-1.html 根據網上源碼修改效果圖： ![](https://box.kancloud.cn/19bbe1159c812039b62aedf199b13ad2_848x524.gif) 源碼： ``` (vl-load-com) (Defun c:AutoHatchArea (/ DATA I LL MID MTO MTXT NUM OBJ OID PNAME SS TXT TXT0 TXT1 UR VAL areaList areaNumList areaEle areaList pname area ) (setq mtxt (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 1 " ") (list 10 0.0 0.0 0.0) (cons 40 5.0) ; 文字高度 (cons 50 0.0) (cons 62 1) (cons 71 5) (cons 72 5) (cons 90 1) (cons 45 1.2) ) ) (setq areaList (tcx 1)) (if (setq i -1) (repeat (length areaList) (setq areaEle (nth (setq i (1+ i)) areaList)) ;取出一個面積項 (setq pname (car areaEle)) ;圖案名稱 (setq area (nth 1 areaEle)) ;面積 (setq midPoint (nth 2 areaEle));填充包圍框的中心點 ;;對相同圖案名稱的項進行編號 (if (null (setq areaNum (cdr (assoc pname areaNumList)))) (setq areaNumList (cons (cons pname 1) areaNumList)) (progn (setq areaNumList (subst (cons pname (1+ areaNum)) (cons pname areaNum) areaNumList)) ) ) (setq txt0 (strcat pname "-" (itoa (cdr (assoc pname areaNumList)))));圖案名稱字符串 (setq txt1 (strcat "A=" (rtos area) "m2")) ;面積字符串 (setq mto (entmake mtxt) mto (vlax-ename->vla-object (entlast)) ) (vla-put-textstring mto (strcat txt0 "\\\\P" txt1)) (vla-put-insertionPoint mto (vlax-3d-point midPoint)) ;(vla-update obj) ) ) (princ) ) ;;返回填充的圖案名稱和面積 (defun tcx ( type0 ;0-將相同圖案名稱的累加在一起；1-相同圖案名稱的也分別計算 / thisdrawing modelspace cset hname area ll na centerPoint minExt maxExt) (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)) modelspace (vla-get-modelspace thisdrawing) ) (if (ssget '((0 . "hatch"))) (progn (vlax-for obj (vla-get-activeselectionset thisdrawing) (setq hname (vla-get-patternname obj) area (/ (vl-catch-all-apply ' vla-get-area (list obj) ) 1000000) ) (vla-getboundingbox obj 'minExt 'maxExt) (setq minExt (vlax-safearray->list minExt)) (setq maxExt (vlax-safearray->list maxExt)) (setq midPoint (list (/ (+ (car minExt) (car maxExt)) 2) (/ (+ (cadr minExt) (cadr maxExt)) 2))) (if (\= (type area) 'REAL) (if (\= type0 0) (if ll (if (setq na (assoc hname ll)) (setq ll (subst (list hname (+ area (cadr na)) midPoint) na ll)) (setq ll (cons (list hname area midPoint) ll)) ) (setq ll (cons (list hname area midPoint) ll)) ) (progn (setq ll (cons (list hname area midPoint) ll)) ) ) ) ) ) ) (princ ll) ) ```