最近学习 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 * (i - 1) / 2
point(i) = cenx + radius * Cos(thisangle)
point(i + 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 中对象的函数，在将碎片联合为多段线时用到（这个函数是抄人家的）

完