'***************************************************** '功能:求得所有相同层的面积 '参数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
望赐教!