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(+ 1)
dx2y2 = dx * dx + dy * dy '该点距比对点的距离
nextdx = comparePt(0) - pin(+ 2)
nextdy = comparePt(1) - pin(+ 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(+ 1)
comparePt(0) = pin(i)
comparePt(1) = pin(+ 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 许多地方都没有搞顺溜,今后逐步完善。

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 博主赞过: