[求助]：如何编写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