AutoCAD VBA 加密多段线

最近学习 AutoCAD VBA 编程,前几天想做加密多段线的没弄出来,现在学会了。

功能

加密 AutoCAD 中的二维多段线。按照设定的距离阈值处理圆弧,将其转换为内接于圆弧的多段线。

使用

此为 VBA 宏脚本,在 AutoCAD 中按”Alt+F8″,填写名字后新建宏,粘贴脚本到编辑框中,按”F5″执行。具体流程可自行搜索。

代码如下:
===================
===================

'多段线插值加密
'功能:多段线炸开,标记每段直线或圆弧的起点,加密圆弧,删除原圆弧,生成面积报告
'需要:完成后再拼合回多段线 只会拼合为面域 拼合多段线 done!
Sub InterpolatePolyline()
Dim pl As AcadLWPolyline
ThisDrawing.Utility.GetEntity pl, Pnt, "指定将被加密的多段线:"

'获取加密距离,正实数,按空格默认为0.5
ThisDrawing.Utility.InitializeUserInput 6
Dim promptStr As String
promptStr = vbCr & "指定加密距离<0.5>):"
On Error Resume Next '这句如不写,则按空格会报错
threshold = ThisDrawing.Utility.GetReal(promptStr)
If threshold = 0 Then threshold = 0.5

Dim plarea As Double: plarea = pl.Area '在炸开前取得polyline的信息
pl.Copy '备份一个原polyline

'炸开
Dim ss As AcadSelectionSet
ThisDrawing.ActiveSelectionSet.Clear
ThisDrawing.SendCommand "Explode" & vbCr & "(handent " & Chr(34) _
& pl.Handle & Chr(34) & ")" & vbCr & vbCr
Set ss = ThisDrawing.ActiveSelectionSet
'清空当前选择集,然后 sendcommand x 碎片自动被收集到当前选择集?

Dim out() As AcadObject: ReDim out(ss.Count - 1) '炸开碎片的数组
Dim vtxcount As Long '统计节点数目
Dim listent As String '预备拼合之后的polyline

For i = 0 To ss.Count - 1
' temp = ThisDrawing.ModelSpace.AddPoint(ss(i).StartPoint)
If ss(i).ObjectName = "AcDbArc" Then '加密碎片中的圆弧
Set out(i) = InterpolateArc(ss(i), threshold)
vtxcount = vtxcount + (UBound(out(i).Coordinates) + 1) \ 2 - 1 '加密圆弧节点数
Else '其余是直线,不去管它
Set out(i) = ss(i)
vtxcount = vtxcount + 1 '直线节点数
End If
listent = listent + axEnt2lspEnt(out(i)) + " "
Next i

ThisDrawing.SendCommand "_pedit" & vbCr & "m" & vbCr & listent & vbCr & _
"y" & vbCr & "j" & vbCr & "0.00001" & vbCr & vbCr

'输出log
ThisDrawing.SelectionSets.Item("ss1").Delete
Set ss = ThisDrawing.SelectionSets.Add("ss1")
ss.Select acSelectionSetLast '获取最后创建的对象
plarea = Format(plarea, "0.000") '原面积
newplarea = Format(ss(0).Area, "0.000") '新面积

MsgBox "加密后节点数:" & vtxcount & vbCr _
& "加密距离:" & Format(threshold, "0.00") & vbCr _
& "原面积:" & plarea & vbCr & "新面积:" & newplarea & vbCr _
& "面积相差:" & Format((newplarea - plarea), "0.000") _
& " (" & Format(((newplarea - plarea) / plarea * 1000), "0.000" & ")")
End Sub

'圆弧插值加密,AcadArc对象 >> 加密后的多段线并删除原圆弧
Public Function InterpolateArc(arc As AcadArc, thres As Variant) As Variant
'内建PI,没法声明为常量
Dim PI As Double: PI = 4 * Atn(1)
Dim threshold As Double: threshold = thres '插值距离
Dim cenx As Double: cenx = arc.Center(0)
Dim ceny As Double: ceny = arc.Center(1)
Dim radius As Double: radius = arc.radius
Dim segment As Long: segment = Int(arc.ArcLength / threshold) + 1
Dim anglesegment As Double
anglesegment = (arc.EndAngle - arc.StartAngle) / segment
'圆弧永远是按逆时针定义角度
'处理endangle已经转过一圈,回到stratpoint之前的情况
If anglesegment < 0 Then anglesegment = (2 * PI + arc.EndAngle - arc.StartAngle) / segment
Dim point() As Double
ReDim point(1 To segment * 2 + 2)
'数组从1开始存储坐标,1 2 圆弧为起点,segment+1 segment+2 为终点
For i = 3 To segment * 2 Step 2
Dim thisangle As Double: thisangle = arc.StartAngle + anglesegment * (- 1) / 2
point(i) = cenx + radius * Cos(thisangle)
point(+ 1) = ceny + radius * Sin(thisangle)
Next i
'首尾端点,必须照抄圆弧的坐标
point(1) = arc.StartPoint(0)
point(2) = arc.StartPoint(1)
point(segment * 2 + 1) = arc.EndPoint(0)
point(segment * 2 + 2) = arc.EndPoint(1)

Set templ = ThisDrawing.ModelSpace.AddLightWeightPolyline(point)
arc.Delete
Set InterpolateArc = templ
End Function

Public Function axEnt2lspEnt(entObj As AcadEntity) As String
Dim entHandle As String
entHandle = entObj.Handle
axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function

==================
==================

其中使用了两个函数:
InterpolateArc 处理针对单一圆弧的加密的函数
axEnt2lspEnt 将 VBA 中的图形对象转换为 lisp 中对象的函数,在将碎片联合为多段线时用到(这个函数是抄人家的)

Advertisements

,

  1. 留下评论

发表评论

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / 更改 )

Twitter picture

You are commenting using your Twitter account. Log Out / 更改 )

Facebook photo

You are commenting using your Facebook account. Log Out / 更改 )

Google+ photo

You are commenting using your Google+ account. Log Out / 更改 )

Connecting to %s

%d 博主赞过: