求帮忙实现 批量框选图形 标注面积 （注意不是点选）

hhaoma

谁能帮我呢 希望能实现 请下载附图进行测试 谢谢！

香田里浪人

对楼主来说，应该不难，用如下程序是否满足楼主要求
(defun c:mjpl(/ ACADDOC ACADSPC OBJAREA OBJLLPOINT OBJRUPOINT SELECTIONSET TEXTBASEPOINT TEXTHEIGHT TEXTINDEX TEXTOBJ)
(setq ss (ssget "x"'((0 . "LINE,LWPOLYLINE,ARC"))))
      (command "PEDITACCEPT" "1")
(if ss
      (command ".pedit" "m" ss "" "j" "0" "w" "0" "" "PEDITACCEPT" "0")
      (command ".pedit" "m" "p" "" "j" "0" "w" "0" "" "PEDITACCEPT" "0")
)
   (vl-load-com)
   (setq AcadDoc (vla-get-activedocument (vlax-get-acad-object)))
   (if (= (getvar "TILEMODE") 1)(setq AcadSpc (vla-get-modelspace AcadDoc))(setq AcadSpc (vla-get-paperspace AcadDoc)))
(setvar"dimzin"0);;保留小数位数时如果位数不足可以补零
   (setq TextHeight (getdist "\n输入标注文字高度:")
TextIndex 1
)
   (ssget '((0 . "LWPOLYLINE")))
(mkla "面积计算" 3)
   (setq Selectionset (vla-get-activeselectionset AcadDoc))
   (if (and TextHeight Selectionset TextIndex)
     (vlax-for Obj Selectionset
       (setq ObjArea (vla-get-area obj)
      ObjLlPoint nil
      ObjRuPoint nil
      )
       (vla-GetBoundingBox Obj 'ObjLlPoint 'ObjRuPoint)
       (setq TextBasePoint (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-safearray->list ObjLlPoint)(vlax-safearray->list ObjRuPoint))
      TextObj (vla-addtext AcadSpc (strcat  "S"(itoa TextIndex)"=" (rtos (/ ObjArea 1)2 3) "㎡") (vlax-3d-point TextBasePoint) TextHeight)
      )
       (vla-put-alignment TextObj acAlignmentCenter)
       (vla-put-TextAlignmentPoint TextObj (vlax-3d-point TextBasePoint))
       (setq TextIndex (1+ TextIndex))      
       )
     )
   )

hhaoma

这应该是世界上最难实现的东西了！估计这个世界上没人会这个吧！这论坛的专家实力不过如此啊

bai2000

楼上的，少子程序

xyp1964

hhaoma 发表于 2014-8-24 08:00
这应该是世界上最难实现的东西了！估计这个世界上没人会这个吧！这论坛的专家实力不过如此啊

浮云……

hhaoma

xyp1964 发表于 2014-8-24 12:06
浮云……

厉害啊！！能教教我吗？

hhaoma

香田里浪人 发表于 2014-8-24 08:08
对楼主来说，应该不难，用如下程序是否满足楼主要求
(defun c:mjpl(/ ACADDOC ACADSPC OBJAREA OBJLLPOINT ...

是啊！没有子程序

香田里浪人

hhaoma 发表于 2014-8-24 12:27
是啊！没有子程序

我觉得可以运行，还要什么子程序，请阁下教我？

hhaoma

香田里浪人 发表于 2014-8-24 12:37
我觉得可以运行，还要什么子程序，请阁下教我？

(mkla "面积计算" 3) 删除这句就能运行了！！！高手啊！太崇拜你了！

xyp1964

hhaoma 发表于 2014-8-24 14:18
(mkla "面积计算" 3) 删除这句就能运行了！！！高手啊！太崇拜你了！

2. (defun mkla (la co)
   
3.   (if (tblsearch "layer" la)
   
4.     (command "-layer" "t" la "")
   
5.     (command "-layer" "m" la "c" co "" "")
   
6.   )
   
7.   (setvar "clayer" la)
   
8.   (setvar "cecolor" "bylayer")
   
9.   (setvar "celtype" "bylayer")
   
10. )

(defun mkla (la co)<br />   (if (tblsearch "layer" la)<br />     (command "-layer" "t" la "")<br />     (command "-layer" "m" la "c" co "" "")<br />   )<br />   (setvar "clayer" la)<br />   (setvar "cecolor" "bylayer")<br />   (setvar "celtype" "bylayer")<br /> )