关于自动计算面积
求个自动求出用多段线闭合成的面域的面积并可以把面积用单行字写入CAD图形里！！！... 本帖最后由 wangshuping42 于 2014-12-3 20:38 编辑我有这个程序，自己写的。可批量操作，还可以提取姓名和面积导出到excel。
http://bbs.mjtd.com/data/attachment/album/201412/03/202043zwzr6xkxyekb6zyv.gif
http://bbs.mjtd.com/data/attachment/album/201412/03/203630j9i9luiid66idjcc.gif
可以分享下吗！！！ (vl-load-com)
(defun c:mj (/)
(setq e (car (entsel "\n 请选择多边形==>>")))
(setq e_obj (vlax-ename->vla-object e))
(vla-getboundingbox e_obj 'minpt 'maxpt)
(setq p1 (vlax-safearray->list minpt))
(setq p2 (vlax-safearray->list maxpt))
(setq mid (mapcar '(lambda (x y) (/ (+ x y) 2.)) p1 p2));;求两点中点
(setq mj (rtos (vla-get-area e_obj) 2 3))
(entmake
(list '(0 . "TEXT")
(cons 1 mj)
(cons 10 mid)
(cons 40 (* (vla-get-area e_obj) 0.0001))
)
)
(setq wjb (cdr (assoc 5 (entget (entlast)))))
(setq wjl (list wjb))
(setq objlt (list e_obj)) ;图元名转换为VLA对象
(setq vrl (vlr-pers
(vlr-object-reactor objlt wjl '((:vlr-modified . c-2l)))
)
)
(princ) ;静默退出
)
(defun c-2l (notifier-object
reactor-object
parameter-list
/
)
(setq mj (rtos (vla-get-area notifier-object) 2 3))
(vla-getboundingbox notifier-object 'minpt 'maxpt)
(setq p1 (vlax-safearray->list minpt))
(setq p2 (vlax-safearray->list maxpt))
(setq mid (mapcar '(lambda (x y) (/ (+ x y) 2.)) p1 p2)) ;;求两点中点
(setq we (handent (car (vlr-data reactor-object)))) ;获取文本图元名
(setq wel (entget we))
(setq wel (subst (vl-list* 10 mid) (assoc 10 wel) wel))
(setq wel (subst (vl-list* 1 mj) (assoc 1 wel) wel))
(setq
wel (subst (vl-list* 40 (* (vla-get-area notifier-object) 0.0001))
(assoc 40 wel)
wel
)
)
(entmod wel) ;更新文本图元表
)
newbuser 发表于 2014-12-3 10:20 static/image/common/back.gif
不知道这个带反应器的和不和您的口味。 shenahe@163.com 发表于 2014-12-3 08:55
可以分享下吗！！！
发邮箱给我 谢谢给位！！！ Sub aa()
Dim region As AcadRegion
Dim SS As AcadSelectionSet
On Error Resume Next
If Not IsNull(ThisDrawing.SelectionSets.Item("sss")) Then
Set SS = ThisDrawing.SelectionSets.Item("sss")
SS.Delete
End If
Set SS = ThisDrawing.SelectionSets.Add("sss")
SS.SelectOnScreen
Dim ents() As AcadEntity
ReDim ents(SS.Count - 1)
Dim i As Integer
For i = 0 To SS.Count - 1
Set ents(i) = SS.Item(i)
Next i
SS.Delete
region = ThisDrawing.ModelSpace.AddRegion(ents)
Dim area1 As AcadRegion
Dim area2 As Double
Dim pnt1 As Variant
Dim pnt2 As Variant
Dim txt As AcadText
Dim hh As Double
ThisDrawing.Utility.GetEntity area1, pnt1, "pick"
area2 = area1.area
pnt2 = ThisDrawing.Utility.GetPoint(, "pick")
hh = ThisDrawing.GetVariable("textsize")
Set txt = ThisDrawing.ModelSpace.AddText(Format(area2, "#.##"), pnt2, Val(hh))
End Sub
crazylsp 发表于 2014-12-3 18:14 static/image/common/back.gif
Sub aa()
Dim region As AcadRegion
谢谢！！！ shenahe@163.com 发表于 2014-12-3 15:14 static/image/common/back.gif
谢谢给位！！！
麻烦你再发次！！邮箱里面下不了
页:
[1]
2