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

wenmaokun

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








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