明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 2922|回复: 16

关于自动计算面积

[复制链接]
发表于 2014-12-2 22:39:58 | 显示全部楼层 |阅读模式
求个自动求出用多段线闭合成的面域的面积并可以把面积用单行字写入CAD图形里!!!...
发表于 2014-12-3 07:50:56 来自手机 | 显示全部楼层
本帖最后由 wangshuping42 于 2014-12-3 20:38 编辑

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




 楼主| 发表于 2014-12-3 08:55:17 | 显示全部楼层
可以分享下吗!!!
发表于 2014-12-3 10:20:14 | 显示全部楼层
  1. (vl-load-com)
  2. (defun c:mj (/)
  3.   (setq e (car (entsel "\n 请选择多边形==>>  ")))
  4.   (setq e_obj (vlax-ename->vla-object e))
  5.   (vla-getboundingbox e_obj 'minpt 'maxpt)
  6.   (setq p1 (vlax-safearray->list minpt))
  7.   (setq p2 (vlax-safearray->list maxpt))
  8.   (setq mid (mapcar '(lambda (x y) (/ (+ x y) 2.)) p1 p2));;求两点中点
  9.   (setq mj (rtos (vla-get-area e_obj) 2 3))
  10.   (entmake
  11.     (list '(0 . "TEXT")
  12.           (cons 1 mj)
  13.           (cons 10 mid)
  14.           (cons 40 (* (vla-get-area e_obj) 0.0001))
  15.     )
  16.   )
  17.   (setq wjb (cdr (assoc 5 (entget (entlast)))))
  18.   (setq wjl (list wjb))
  19.   (setq objlt (list e_obj))        ;图元名转换为VLA对象
  20.   (setq        vrl (vlr-pers
  21.               (vlr-object-reactor objlt wjl '((:vlr-modified . c-2l)))
  22.             )
  23.   )
  24.   (princ)                                ;静默退出
  25. )
  26. (defun c-2l (notifier-object
  27.              reactor-object
  28.              parameter-list
  29.              /
  30.             )
  31.   (setq mj (rtos (vla-get-area notifier-object) 2 3))
  32.   (vla-getboundingbox notifier-object 'minpt 'maxpt)
  33.   (setq p1 (vlax-safearray->list minpt))
  34.   (setq p2 (vlax-safearray->list maxpt))
  35.   (setq mid (mapcar '(lambda (x y) (/ (+ x y) 2.)) p1 p2)) ;;求两点中点
  36.   (setq we (handent (car (vlr-data reactor-object)))) ;获取文本图元名
  37.   (setq wel (entget we))
  38.   (setq wel (subst (vl-list* 10 mid) (assoc 10 wel) wel))
  39.   (setq wel (subst (vl-list* 1 mj) (assoc 1 wel) wel))
  40.   (setq
  41.     wel        (subst (vl-list* 40 (* (vla-get-area notifier-object) 0.0001))
  42.                (assoc 40 wel)
  43.                wel
  44.         )
  45.   )
  46.   (entmod wel)                                ;更新文本图元表
  47. )

发表于 2014-12-3 10:20:47 | 显示全部楼层
newbuser 发表于 2014-12-3 10:20

不知道这个带反应器的和不和您的口味。
发表于 2014-12-3 13:14:33 来自手机 | 显示全部楼层
shenahe@163.com 发表于 2014-12-3 08:55
可以分享下吗!!!

发邮箱给我

点评

可以分享代码学习一下吗? 369688161@qq.com  发表于 2023-12-3 22:15
 楼主| 发表于 2014-12-3 15:14:07 | 显示全部楼层
谢谢给位!!!
发表于 2014-12-3 18:14:41 | 显示全部楼层
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
 楼主| 发表于 2014-12-7 20:22:29 | 显示全部楼层
crazylsp 发表于 2014-12-3 18:14
Sub aa()
  
  Dim region As AcadRegion

谢谢!!!
 楼主| 发表于 2014-12-7 20:26:21 | 显示全部楼层
shenahe@163.com 发表于 2014-12-3 15:14
谢谢给位!!!

麻烦你再发次!!邮箱里面下不了
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-25 09:33 , Processed in 0.192822 second(s), 25 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表