VBA开发的剖断面的原程序

Sub PDM()
MsgBox "你现在运行的是在等高线上自动剖取断面的程序，请确定等高线坐标为三维坐标，已绘制用于剖截断面的一条多义线", vbOKOnly, "AutoCAD"
Dim SS As AcadSelectionSet '声明选择集变量
Dim Ft(0) As Integer, Fd(0) As Variant '声明选择集过滤器数组变量
Dim P() As Double '声明一个双精度型动态数组,用于保存所有交点坐标
Dim v As Variant '声明一个变体型变量,用于提取两直线的交点
Dim I As Long, J As Long '循环变量
Dim S As String '一个字符串,用于消息框
Dim pl1 As AcadLWPolyline
Dim h As Double
Dim h2 As Double
Dim text() As String
Dim text3 As AcadText
Dim insertpoint1(2) As Double
Dim pt1() As Double
Dim point1 As Variant
k = 0
On Error Resume Next
Set SS1 = ThisDrawing.SelectionSets.Add("SS1") '新建选择集
Set ss2 = ThisDrawing.SelectionSets.Add("SS2")
Ft(0) = 0 '定义过滤器,组码为0,检查对象类型
Fd(0) = "LWPOLYLINE" '对象类型为直线
MsgBox "请选择断面基线", vbOKOnly, "AutoCAD"
SS1.SelectOnScreen '选择所有直线
MsgBox "请从一个方向按顺序选择等高线", vbOKOnly, "AutoCAD"
ss2.SelectOnScreen '选择所有直线
MsgBox "请指定生成断面的位置", vbOKOnly, "AutoCAD"
point1 = ThisDrawing.Utility.GetPoint
ReDim pt1((ss2.Count) * 2 - 1) As Double
ReDim text((ss2.Count) * 2 - 1) As String
If ss2.Count >= 1 And SS1.Count >= 1 Then '检查被加入选择集的直线数量,只有数量大于或等于2时才能检查交点
For I = 0 To SS1.Count - 1 '用嵌套循环方式检查某条直线与其它所有直线的交点
For J = 0 To ss2.Count - 1
h = ss2.Item(J).Elevation
ss2.Item(J).Elevation = SS1.Item(I).Elevation
v = SS1.Item(I).IntersectWith(ss2.Item(J), acExtendNone) '获得交点,用两条直线均不延伸的模式
ss2.Item(J).Elevation = h
If UBound(v) = 2 Then '检查是否有交点
If UBound(P, 2) < 0 Then '重定义数组
ReDim P(2, 0)
Else
ReDim Preserve P(2, UBound(P, 2) + 1)
End If

P(0, UBound(P, 2)) = v(0) '把交点坐标存入动态数组
P(1, UBound(P, 2)) = v(1)
P(2, UBound(P, 2)) = h

If J = 0 Then
x = v(0)
y = v(1)
z = h
End If
pt1(k) = Sqr((v(0) - x) * (v(0) - x) + (v(1) - y) * (v(1) - y)) + point1(0)
insertpoint1(0) = pt1(k)
k = k + 1
insertpoint1(1) = h + point1(1) - z
pt1(k) = h + point1(1) - z
k = k + 1

Set text3 = ThisDrawing.ModelSpace.AddText(h, insertpoint1, 0.3)

End If
Next
Next
Set pl1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt1)


If UBound(P, 2) < 0 Then
MsgBox "没有交点", vbOKOnly, "AutoCAD"
Else
S = "共有 " & UBound(P, 2) + 1 & " 个交点"
For I = 0 To UBound(P, 2)
S = S & vbCrLf & P(0, I) & "," & P(1, I) & "," & P(2, I)
Next
End If

Else
MsgBox "没有正确选择多段线", vbOKOnly, "AutoCAD"
End If
SS1.Delete '删除用过的选择集
ss2.Delete '删除用过的选择集
End Sub