如何编写VBA求解多个不规则封闭图形的总面积，总周长，个数？
在AutoCAD2000和2002上怎样编写VBA程序，可以求出图形上所有封闭的但不规则的图形的总面积，封闭图形的个数，单个图形的面积，及图形的总周长与平均周长？急盼解答！ 这个程序给你参考,你拿去改改就可以用了,计算周长和平均边长你自己加进去吧! 刚才忘了帖,呵呵~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 FdataAs 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) = "PolyLINE"
'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 谢谢你回复得这么及时，但我好像用不好！能再给点建议吗？ 这个程序你直接用肯定是不好用的,因为这是我针对单位的测绘软件写的一个程序,如果你要用就要修改一下,给你这个程序是让你参考的.,因为我最近很忙,所以没有时间修改给你! 拜托大侠，我不是搞专业VBA开发的，做这个程序是想处理一些实验数据，真的急用，请一定抽空尽早帮我全部搞定，万分感激了！QQ：21744705 这是图形，大家试试吧
他的要求是：
外框去掉，双线变单线，再求面积等
看看大家能不能帮到你,我这段时间太忙,不好意思! 注意程序需要加载VLAX类和CURVE类
程序处理过程调用了(gc)来强制释放内存，不然会出错。
Sub GetTolArea()
ThisDrawing.SendCommand "(vl-load-com)" & vbCr
Dim CurveObj As Curve
Set CurveObj = New Curve
Dim VlaxObj As VLAX
Set VlaxObj = New VLAX
Dim OutEnt As AcadEntity
Dim Pnt As Variant
ThisDrawing.Utility.GetEntity OutEnt, Pnt, "选择外框："
Dim MinBox As Variant
Dim MaxBox As Variant
Dim OutArea As Double
Dim OutLeng As Double
OutEnt.GetBoundingBox MinBox, MaxBox
If OutEnt.ObjectName = "AcDbRegion" Then
OutArea = OutEnt.Area
OutLeng = OutEnt.Perimeter
Else
Set CurveObj.Entity = OutEnt
OutArea = CurveObj.Area
OutLeng = CurveObj.length
End If
'Set CurveObj.Entity = OutEnt
Dim ss As AcadSelectionSet
Set ss = CreatSSet
Dim FType(0) As Integer
Dim FData(0) As Variant
FType(0) = 0
FData(0) = "SPLINE"
ss.Select acSelectionSetWindow, MinBox, MaxBox, FType, FData
'Debug.Print ss.Count
Dim i As Integer
Dim InArea() As Double
Dim InLeng() As Double
Dim j As Integer
Dim Ent As AcadEntity
ReDim Preserve InArea(0) As Double
ReDim Preserve InLeng(0) As Double
For i = 0 To ss.Count - 1
If ss.Item(i).ObjectID <> OutEnt.ObjectID Then
Set Ent = ss(i)
Set CurveObj.Entity = Ent
VlaxObj.EvalLispExpression "(gc)"
If i <> 0 Then
j = UBound(InArea) + 1
ReDim Preserve InArea(j) As Double
ReDim Preserve InLeng(j) As Double
InArea(j) = CurveObj.Area
InLeng(j) = CurveObj.length
Else
InArea(0) = CurveObj.Area
InLeng(0) = CurveObj.length
End If
End If
Next
Dim TolArea As Double
Dim TolLeng As Double
Dim AreaPer As Double
Dim dispMsg As String
dispMsg = "外框的面积为:" & OutArea & "，周长为：" & OutLeng & vbCrLf & vbCrLf
dispMsg = dispMsg & "内部曲线的面积及周长如下：" & vbCrLf
For i = 0 To UBound(InArea)
dispMsg = dispMsg & "曲线" & i & "面积：" & InArea(i) & "，周长：" & InLeng(i) & vbCrLf
TolArea = TolArea + InArea(i)
TolLeng = TolLeng + InLeng(i)
Next
dispMsg = dispMsg & vbCrLf
dispMsg = dispMsg & "总面积为:" & TolArea & " 总周长为：" & TolLeng & vbCrLf & vbCrLf
AreaPer = TolArea / OutArea * 100
dispMsg = dispMsg & "内部曲线面积总各占外框面积的百分比:" & AreaPer & "%"
'MsgBox dispMsg
ThisDrawing.Utility.Prompt dispMsg
End Sub
Function CreatSSet()
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = ThisDrawing.SelectionSets.Add("mccad")
If Err Then
Err.Clear
Set ss = ThisDrawing.SelectionSets("mccad")
ss.Clear
End If
Set CreatSSet = ss
End Function
用了，很好用，谢谢！：）
很棒！只是它只能算我从JPG通过cordraw转化过来的图形，线条是拟和的。但如果我直接手工画出来就不行了，它只能算外框面积，里面所有的图形面积和周长都为零，该怎么改呢？