AutoCAD VBA 抽稀多段线

最近迫于工作压力开始学 AutoCAD VBA 编程。有好多打算弄成自动处理的工作，预备一点一点搞定。对着手册折腾一番后，研究出了将多段线抽稀的 VBA 宏（其实我是想做多段线加密的，但暂时没能搞出来……）。

功能

抽稀（优化）AutoCAD 中的二维多段线。依次计算线上原有点之间的距离，合并在距离阈值之内的点。

使用

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

代码如下： =================== ===================

'抽稀多段线
'利用Polyline原有的点优化线条，凡阈值内的点都被归并为一处，保留起止点
Sub RefineLine()
Dim pl As AcadLWPolyline
ThisDrawing.Utility.GetEntity pl, Pnt, "指定将被抽稀的多段线："

'获取正实数，按空格默认为0.5
ThisDrawing.Utility.InitializeUserInput 6
' 1 不接受 NULL 输入 防止用户只按回车或空格来响应输入请求
' 2 不接受输入零值(0) 防止用户输入 0 来响应输入请求
' 4 不接受输入负值 防止用户输入负值来响应输入请求
Dim promptStr As String
promptStr = vbCr & "指定阈值，此距离内的冗余节点将被合并<0.5>):"
On Error Resume Next '这句如不写，则按空格会报错
threshold = ThisDrawing.Utility.GetReal(promptStr)
If threshold = 0 Then
threshold = 0.5
End If

Dim pin As Variant '输入坐标组
pin = pl.Coordinates
up = UBound(pin)

Dim pout() As Double '输出坐标组
ReDim pout(0 To 1)
'动态数组真麻烦，必须这么定义，然后往里面写几个东西，否则没法直接扩充

Dim comparePt(0 To 1) As Double '比对点坐标组，就一组

'保持首端点不变
pout(0) = pin(0)
pout(1) = pin(1)
comparePt(0) = pin(0)
comparePt(1) = pin(1)

For i = 2 To up - 3 Step 2 '依次分析处理第2个点直到倒数第二点
dx = comparePt(0) - pin(i)
dy = comparePt(1) - pin(i + 1)
dx2y2 = dx * dx + dy * dy '该点距比对点的距离
nextdx = comparePt(0) - pin(i + 2)
nextdy = comparePt(1) - pin(i + 3)
nextdx2y2 = nextdx * nextdx + nextdy * nextdy '该点下一点距比对点的距离
'在该点超过阈值，或该点下一点超过阈值时，记录为有效的点，同时设此为新比对点
'不满足条件的是废点，忽略之
If dx2y2 > threshold * threshold Or nextdx2y2 > threshold * threshold Then '扩充output数组，写入新点
leng = UBound(pout)
ReDim Preserve pout(leng + 2)
pout(leng + 1) = pin(i)
pout(leng + 2) = pin(i + 1)
comparePt(0) = pin(i)
comparePt(1) = pin(i + 1)
End If
Next i

leng = UBound(pout)
ReDim Preserve pout(leng + 2) '处理末端点，照抄其坐标，不能改变
pout(leng + 1) = pin(up - 1)
pout(leng + 2) = pin(up)

Set newline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pout)
If pl.Closed Then '原线条若闭合，则同样闭合
newline.Closed = True
End If

'统计面积
pla = Format(pl.Area, "0.000")
nla = Format(newline.Area, "0.000")

MsgBox "原节点数：" & up & vbCr & "新节点数：" & UBound(pout) & vbCr _
& "阈值：" & Format(threshold, "0.00") & vbCr _
& "原面积：" & pla & vbCr & "新面积：" & nla & vbCr _
& "面积相差：" & Format((nla - pla), "0.000") _
& " (" & Format(((nla - pla) / pla * 1000), "0.000‰" & ")")
End Sub

================== ================== 初学 VBA 许多地方都没有搞顺溜，今后逐步完善。

完