求完善并扩展 填充面积统计

oldenn

在论坛下载了一个lsp，可以实现命令行返回所选的不同填充面积分别汇总，详附件tcx.lsp，仅供参考【抱歉一下找不到原帖地址了，在此感谢。】
要求完善并扩展达到以下功能：

在图上标注填充图案的面积，以填充图案名称命名，有多处相同填充图案的应编号。


简化了一下，请高手帮忙

mmmmmm

(Defun c:AutoHatchArea (/     DATA  I          LL        MID   MTO   MTXT  NUM
                        OBJ   OID   PNAME SS        TXT   TXT0  TXT1  UR
                        VAL
                       )
  (setq        txt0 "%<\\AcObjProp Object(%<\\_ObjId 00000000>%).PatternName \\f \042%tc1\042>%-"
        txt1 "\\PA=%<\\AcObjProp Object(%<\\_ObjId 00000000>%).Area \\f \042%lu2%pr2%ps[,m2]%ct8[1e-006]\042>%"
        mtxt (list (cons 0 "MTEXT")
                   (cons 100 "AcDbEntity")
                   (cons 100 "AcDbMText")
                   (cons 1 " ")
                   (list 10 0.0 0.0 0.0)
                   (cons 40 50.0) ; MTEXT HEIGHT
                   (cons 50 0.0)
                   (cons 62 1)
                   (cons 71 5)
                   (cons 72 5)
                   (cons 90 1)
                   (cons 45 1.2)
             )
  )
  (if (setq i  -1
            ss (ssget '((0 . "hatch")))
      )
    (repeat (sslength ss)
      (setq obj          (vlax-ename->vla-object (ssname ss (setq i (1+ i))))
            oid          (vl-prin1-to-string (vlax-get-property obj "ObjectID"))
            pname (vlax-get-property obj "PatternName")
      )
      (if (null (setq num (cdr (assoc pname data))))
        (setq num  1
              data (list (cons pname num))
        )
        (setq num (1+ num))
      )
      (setq data (subst (cons pname num) (assoc pname data) data))
      (vla-getboundingbox obj 'll 'ur)
      (setq ll        (vlax-safearray->list ll)
            ur        (vlax-safearray->list ur)
            mid        (polar ll (angle ll ur) (* 0.5 (distance ll ur)))
            mid        (trans mid 0 1)
            val        (strcat        (vl-string-subst oid "00000000" txt0)
                        (itoa num)
                        (vl-string-subst oid "00000000" txt1)
                )
            txt        (subst (cons 10 mid) (assoc 10 mtxt) mtxt)
            mto        (entmake txt)
            mto        (vlax-ename->vla-object (entlast))
      )
      (vla-put-textstring mto val)
    )
  )
  (princ)
)

429014673

要求很高，就看高手了

oldenn

顶下，求高人出手

lizhiqiang9801

顶贴 期待高手出手

oldenn

顶上。。。。。。。。

oldenn

简化了一下，请高手帮忙

cxs259

7楼基本满足楼主的要求，请楼主把30个明经币给他吧

bai2000

7楼的，能改下，字体大小可以量取定义最好

mmmmmm

不要给我，捐到论坛吧。