找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 953|回复: 0

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

[复制链接]
发表于 2007-9-3 16:35:39 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×
如何编写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
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-11-22 04:34 , Processed in 0.163940 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表