关于自动计算面积

shenahe@163.com · 发表于 2014-12-2 22:39

求个自动求出用多段线闭合成的面域的面积并可以把面积用单行字写入CAD图形里！！！...

wangshuping42 · 发表于 2014-12-3 07:50

本帖最后由 wangshuping42 于 2014-12-3 20:38 编辑

我有这个程序，自己写的。可批量操作，还可以提取姓名和面积导出到excel。

shenahe@163.com · 发表于 2014-12-3 08:55

可以分享下吗！！！

newbuser · 发表于 2014-12-3 10:20

(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) ;更新文本图元表
)

(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

newbuser 发表于 2014-12-3 10:20

不知道这个带反应器的和不和您的口味。

wangshuping42 · 发表于 2014-12-3 13:14

shenahe@163.com 发表于 2014-12-3 08:55
可以分享下吗！！！

发邮箱给我

shenahe@163.com · 发表于 2014-12-3 15:14

谢谢给位！！！

crazylsp · 发表于 2014-12-3 18:14

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

shenahe@163.com · 发表于 2014-12-7 20:22

crazylsp 发表于 2014-12-3 18:14
Sub aa()

Dim region As AcadRegion

谢谢！！！

shenahe@163.com · 发表于 2014-12-7 20:26

shenahe@163.com 发表于 2014-12-3 15:14
谢谢给位！！！

麻烦你再发次！！邮箱里面下不了

账号		自动登录	找回密码
密码			注册

关于自动计算面积

点评