如何编写VBA求解多个不规则封闭图形的总面积，总周长，个数？

airseejiun

在AutoCAD2000和2002上怎样编写VBA程序，可以求出图形上所有封闭的但不规则的图形的总面积，封闭图形的个数，单个图形的面积，及图形的总周长与平均周长？急盼解答！

myfreemind

这个程序给你参考,你拿去改改就可以用了,计算周长和平均边长你自己加进去吧!

myfreemind

刚才忘了帖,呵呵~


Option Explicit
Sub smarea() '批量计算多边形面积程序
On Error Resume Next
Dim i As Integer
Dim areaobj As AcadLWPolyline '轻量多义线对象
Dim sset As AcadSelectionSet '选择集
Dim minpnt As Variant '对象边框最小点坐标
Dim maxpnt As Variant '对象边框最大点坐标
Dim areains(0 To 2) As Double '文本插入点坐标
Dim txtarea As String '面积文本
Dim txtins As String '插入文本综合
Dim ms As String '亩文本
Dim txtobj As AcadText '文字对象
Dim Ftype As Variant
Dim Fdata  As Variant
Dim entity As AcadEntity
Dim hatchobj As AcadHatch
Dim pname As String '阴影名称
Dim pype As Long '阴影类型
Dim outloop(0 To 0) As AcadEntity '阴影外部边界
Dim zminpnt(0 To 2) As Double '不闭合对象的缩放点左下角点坐标
Dim zmaxpnt(0 To 2) As Double '不闭合对象的缩放点右上角点坐标
Dim sclayer As String '当前图层名


Dim us1 As Integer '比例尺
us1 = ThisDrawing.GetVariable("userr1") '取得比例尺
sclayer = ThisDrawing.GetVariable("clayer")
'删除存在的选择集
If ThisDrawing.SelectionSets.Count > 0 Then
        For i = 0 To ThisDrawing.SelectionSets.Count - 1
        ThisDrawing.SelectionSets.Item(i).Clear
        ThisDrawing.SelectionSets.Item(i).Delete
        Next
End If

'**************
Dim gpCode(3) As Integer, dataValue(3) As Variant

  '创建过滤器
  '本例为过滤polyline or lwpolyline
  '使用的是变体数组进行定义

  '分组运算符
  gpCode(0) = -4
  dataValue(0) = "<or"

  'polyline过滤器
  gpCode(1) = 0
  dataValue(1) = "olyLINE"

  'lwpolyline过滤器
  gpCode(2) = 0
  dataValue(2) = "LwPolyline"
  
  



  '分组运算符
  gpCode(3) = -4
  dataValue(3) = "or>"

  Ftype = gpCode
  Fdata = dataValue
'**************





'创建选择集(只选择在当前图层的多边形对象)
Set sset = ThisDrawing.SelectionSets.Add("smarea1")
'选择
sset.Select acSelectionSetAll, , , Ftype, Fdata

For Each entity In sset
If entity.Layer = sclayer Then '只计算当前图层的多边形
'取得图形边框坐标（检查闭合放在后面）
entity.GetBoundingBox minpnt, maxpnt
'设置文字插入点坐标
areains(0) = (minpnt(0) + maxpnt(0)) / 2
areains(1) = (minpnt(1) + maxpnt(1)) / 2
areains(2) = 0
'将不闭合的图形显示在窗口中间(以两点缩放)
zminpnt(0) = minpnt(0) - 250
zminpnt(1) = minpnt(1) - 250
zminpnt(2) = 0
zmaxpnt(0) = maxpnt(0) + 250
zmaxpnt(1) = maxpnt(1) + 250
zmaxpnt(2) = 0

'若不闭合
If entity.Closed = False Then
'将视窗移动到非闭合图形
ThisDrawing.Application.ZoomWindow zminpnt, zmaxpnt
  entity.Color = acRed
entity.Highlight True '高亮
MsgBox "当前视口图形不闭合，请检查！"


Exit Sub
End If


'判断比例尺

Select Case us1
Case 500
txtarea = entity.Area / 4

Case 1000
txtarea = entity.Area
Case 2000
txtarea = entity.Area * 4
Case Else
MsgBox "你的比例尺不在可计算之列,请检查你的比例尺"
Exit Sub

End Select


''亩和平方米均取三位 , 自定义格式
ms = Format(txtarea / 666.6666, "#0.000")
txtarea = Format(txtarea, "#0.000")
''插入的文本内容
txtins = "S=" & txtarea & "平方米=" & ms & "亩"
''插入文本
Set txtobj = ThisDrawing.ModelSpace.AddText(txtins, areains, 5)
''设置文本颜色
txtobj.Color = acGreen
''*******************************
''创建阴影填充对象

Dim ptype As Long
pname = "ANSI31"
ptype = 0
'创建关联阴影对象
Set hatchobj = ThisDrawing.ModelSpace.AddHatch(ptype, pname, True)
hatchobj.PatternScale = 5
'设置外部边界
Set outloop(0) = entity
'为外部边界添加阴影
hatchobj.AppendOuterLoop (outloop)
hatchobj.Evaluate '求值
End If
''
Next
sset.Clear
sset.Delete
End Sub

airseejiun

谢谢你回复得这么及时，但我好像用不好！能再给点建议吗？

myfreemind

这个程序你直接用肯定是不好用的,因为这是我针对单位的测绘软件写的一个程序,如果你要用就要修改一下,给你这个程序是让你参考的.,因为我最近很忙,所以没有时间修改给你!

airseejiun

拜托大侠，我不是搞专业VBA开发的，做这个程序是想处理一些实验数据，真的急用，请一定抽空尽早帮我全部搞定，万分感激了！QQ：21744705[em00]

mccad

这是图形，大家试试吧
他的要求是：
外框去掉，双线变单线，再求面积等

myfreemind

看看大家能不能帮到你,我这段时间太忙,不好意思!

mccad

注意程序需要加载VLAX类和CURVE类
程序处理过程调用了(gc)来强制释放内存，不然会出错。

2. Sub GetTolArea()
   
3.     ThisDrawing.SendCommand "(vl-load-com)" & vbCr
   
4.     Dim CurveObj As Curve
   
5.     Set CurveObj = New Curve
   
6.     Dim VlaxObj As VLAX
   
7.     Set VlaxObj = New VLAX
   
8.     Dim OutEnt As AcadEntity
   
9.     Dim Pnt As Variant
   
10.     ThisDrawing.Utility.GetEntity OutEnt, Pnt, "选择外框："
    
11.     Dim MinBox As Variant
    
12.     Dim MaxBox As Variant
    
13.     Dim OutArea As Double
    
14.     Dim OutLeng As Double
    
15.     OutEnt.GetBoundingBox MinBox, MaxBox
    
16.     If OutEnt.ObjectName = "AcDbRegion" Then
    
17.         OutArea = OutEnt.Area
    
18.         OutLeng = OutEnt.Perimeter
    
19.     Else
    
20.         Set CurveObj.Entity = OutEnt
    
21.         OutArea = CurveObj.Area
    
22.         OutLeng = CurveObj.length
    
23.     End If
    
24.     'Set CurveObj.Entity = OutEnt
    
25.     Dim ss As AcadSelectionSet
    
26.     Set ss = CreatSSet
    
27.     Dim FType(0) As Integer
    
28.     Dim FData(0) As Variant
    
29.     FType(0) = 0
    
30.     FData(0) = "SPLINE"
    
31.     ss.Select acSelectionSetWindow, MinBox, MaxBox, FType, FData
    
32.     'Debug.Print ss.Count
    
33.     Dim i As Integer
    
34.     Dim InArea() As Double
    
35.     Dim InLeng() As Double
    
36.     Dim j As Integer
    
37.     Dim Ent As AcadEntity
    
38.     ReDim Preserve InArea(0) As Double
    
39.     ReDim Preserve InLeng(0) As Double
    
40.     For i = 0 To ss.Count - 1
    
41.         If ss.Item(i).ObjectID <> OutEnt.ObjectID Then
    
42.             Set Ent = ss(i)
    
43.             Set CurveObj.Entity = Ent
    
44.             VlaxObj.EvalLispExpression "(gc)"
    
45.             If i <> 0 Then
    
46.                 j = UBound(InArea) + 1
    
47.                 ReDim Preserve InArea(j) As Double
    
48.                 ReDim Preserve InLeng(j) As Double
    
49.                 InArea(j) = CurveObj.Area
    
50.                 InLeng(j) = CurveObj.length
    
51.             Else
    
52.                 InArea(0) = CurveObj.Area
    
53.                 InLeng(0) = CurveObj.length
    
54.             End If
    
55.         End If
    
56.     Next
    
57.     Dim TolArea As Double
    
58.     Dim TolLeng As Double
    
59.     Dim AreaPer As Double
    
60.     Dim dispMsg As String
    
61.     dispMsg = "外框的面积为:" & OutArea & "，周长为：" & OutLeng & vbCrLf & vbCrLf
    
62.     dispMsg = dispMsg & "内部曲线的面积及周长如下：" & vbCrLf
    
63.     For i = 0 To UBound(InArea)
    
64.         dispMsg = dispMsg & "曲线" & i & "面积：" & InArea(i) & "，周长：" & InLeng(i) & vbCrLf
    
65.         
    
66.         TolArea = TolArea + InArea(i)
    
67.         TolLeng = TolLeng + InLeng(i)
    
68.     Next
    
69.     dispMsg = dispMsg & vbCrLf
    
70.     dispMsg = dispMsg & "总面积为:" & TolArea & " 总周长为：" & TolLeng & vbCrLf & vbCrLf
    
71.     AreaPer = TolArea / OutArea * 100
    
72.     dispMsg = dispMsg & "内部曲线面积总各占外框面积的百分比:" & AreaPer & "%"
    
73.     'MsgBox dispMsg
    
74.     ThisDrawing.Utility.Prompt dispMsg
    
75. End Sub
    
76. Function CreatSSet()
    
77.     Dim ss As AcadSelectionSet
    
78.     On Error Resume Next
    
79.     Set ss = ThisDrawing.SelectionSets.Add("mccad")
    
80.     If Err Then
    
81.         Err.Clear
    
82.         Set ss = ThisDrawing.SelectionSets("mccad")
    
83.         ss.Clear
    
84.     End If
    
85.     Set CreatSSet = ss
    
86. End Function
    

Sub GetTolArea()<br />     ThisDrawing.SendCommand "(vl-load-com)" & vbCr<br />     Dim CurveObj As Curve<br />     Set CurveObj = New Curve<br />     Dim VlaxObj As VLAX<br />     Set VlaxObj = New VLAX<br />     Dim OutEnt As AcadEntity<br />     Dim Pnt As Variant<br />     ThisDrawing.Utility.GetEntity OutEnt, Pnt, "选择外框："<br />     Dim MinBox As Variant<br />     Dim MaxBox As Variant<br />     Dim OutArea As Double<br />     Dim OutLeng As Double<br />     OutEnt.GetBoundingBox MinBox, MaxBox<br />     If OutEnt.ObjectName = "AcDbRegion" Then<br />         OutArea = OutEnt.Area<br />         OutLeng = OutEnt.Perimeter<br />     Else<br />         Set CurveObj.Entity = OutEnt<br />         OutArea = CurveObj.Area<br />         OutLeng = CurveObj.length<br />     End If<br />     'Set CurveObj.Entity = OutEnt<br />     Dim ss As AcadSelectionSet<br />     Set ss = CreatSSet<br />     Dim FType(0) As Integer<br />     Dim FData(0) As Variant<br />     FType(0) = 0<br />     FData(0) = "SPLINE"<br />     ss.Select acSelectionSetWindow, MinBox, MaxBox, FType, FData<br />     'Debug.Print ss.Count<br />     Dim i As Integer<br />     Dim InArea() As Double<br />     Dim InLeng() As Double<br />     Dim j As Integer<br />     Dim Ent As AcadEntity<br />     ReDim Preserve InArea(0) As Double<br />     ReDim Preserve InLeng(0) As Double<br />     For i = 0 To ss.Count - 1<br />         If ss.Item(i).ObjectID <> OutEnt.ObjectID Then<br />             Set Ent = ss(i)<br />             Set CurveObj.Entity = Ent<br />             VlaxObj.EvalLispExpression "(gc)"<br />             If i <> 0 Then<br />                 j = UBound(InArea) + 1<br />                 ReDim Preserve InArea(j) As Double<br />                 ReDim Preserve InLeng(j) As Double<br />                 InArea(j) = CurveObj.Area<br />                 InLeng(j) = CurveObj.length<br />             Else<br />                 InArea(0) = CurveObj.Area<br />                 InLeng(0) = CurveObj.length<br />             End If<br />         End If<br />     Next<br />     Dim TolArea As Double<br />     Dim TolLeng As Double<br />     Dim AreaPer As Double<br />     Dim dispMsg As String<br />     dispMsg = "外框的面积为:" & OutArea & "，周长为：" & OutLeng & vbCrLf & vbCrLf<br />     dispMsg = dispMsg & "内部曲线的面积及周长如下：" & vbCrLf<br />     For i = 0 To UBound(InArea)<br />         dispMsg = dispMsg & "曲线" & i & "面积：" & InArea(i) & "，周长：" & InLeng(i) & vbCrLf<br />         <br />         TolArea = TolArea + InArea(i)<br />         TolLeng = TolLeng + InLeng(i)<br />     Next<br />     dispMsg = dispMsg & vbCrLf<br />     dispMsg = dispMsg & "总面积为:" & TolArea & " 总周长为：" & TolLeng & vbCrLf & vbCrLf<br />     AreaPer = TolArea / OutArea * 100<br />     dispMsg = dispMsg & "内部曲线面积总各占外框面积的百分比:" & AreaPer & "%"<br />     'MsgBox dispMsg<br />     ThisDrawing.Utility.Prompt dispMsg<br /> End Sub<br /> Function CreatSSet()<br />     Dim ss As AcadSelectionSet<br />     On Error Resume Next<br />     Set ss = ThisDrawing.SelectionSets.Add("mccad")<br />     If Err Then<br />         Err.Clear<br />         Set ss = ThisDrawing.SelectionSets("mccad")<br />         ss.Clear<br />     End If<br />     Set CreatSSet = ss<br /> End Function<br />

airseejiun

很棒！
只是它只能算我从JPG通过cordraw转化过来的图形，线条是拟和的。但如果我直接手工画出来就不行了，它只能算外框面积，里面所有的图形面积和周长都为零，该怎么改呢？