'*****************************************************
'功能：求得所有相同层的面积
'参数1：
'参数2：
'参数2：
'返回：面积
'*****************************************************
Public Function MulLayerArea() As Double
Dim PointObj As AcadPoint '用户获得的实体上任意一点
Dim Ps As Variant '用户获得的任意一点坐标
Dim LayerName As AcadLayer '用户获得的坐标点图层
Dim SpaceCount As Long
Dim n As Integer
Dim EntityObj As AcadEntity '遍历的实体
Dim RegionObj As Variant '创建所有具有相同层的面域
Dim AllLayerArea As Double '所有相同层的面积
AllLayerArea = 0
Ps = ThisDrawing.Utility.GetPoint(, "指定内部点")
Set PointObj = ThisDrawing.ModelSpace.AddPoint(Ps)
'LayerName = PointObj.Layer
For Each EntityObj In ThisDrawing.ModelSpace
'Set EntityObj = ThisDrawing.ModelSpace.Item(n)
If EntityObj.Layer = PointObj.Layer Then
RegionObj = ThisDrawing.ModelSpace.AddRegion(EntityObj)
AllLayerArea = AllLayerArea + RegionObj.Area
End If
Next EntityObj
MsgBox AllLayerArea
End Function望赐教！
置顶卡
