请问下,原来是提取普通多段线坐标的宏代码如何修改为提取三维多段线的坐标。
Option Explicit
Sub Test2()
On Error Resume Next
Dim ele As AcadLine
Dim ele1 As AcadLWPolyline
Dim i, j, index As Integer
Dim get3Dpts As Variant
Dim astr As String
Open "F:\EleData.txt" For Output As #1 '文件保存路径,Append是添加,Output是覆盖
index = 0
For i = 0 To ThisDrawing.ModelSpace.Count - 1
If (ThisDrawing.ModelSpace.Item(i).ObjectName = "AcDbline") And (InStr(1, ThisDrawing.ModelSpace.Item(i).Layer, "首曲线") > 0 Or InStr(1, ThisDrawing.ModelSpace.Item(i).Layer, "计曲线") > 0) Then '41、Index 是图层名称,需要根据实际情况修改
index = index + 1 '线段
Set ele = ThisDrawing.ModelSpace.Item(i)
astr = FormatNumber(ele.StartPoint(0), 2, vbFalse, vbFalse, vbFalse) + " " + FormatNumber(ele.StartPoint(1), 2, vbFalse, vbFalse, vbFalse) + " " + FormatNumber(ele.StartPoint(2), 2, vbFalse, vbFalse, vbFalse)
index = index + 1
astr = astr + vbCrLf + FormatNumber(ele.EndPoint(0), 2, vbFalse, vbFalse, vbFalse) + "," + FormatNumber(ele.EndPoint(1), 2, vbFalse, vbFalse, vbFalse) + "," + FormatNumber(ele.EndPoint(2), 2, vbFalse, vbFalse, vbFalse)
Print #1, astr
ElseIf (ThisDrawing.ModelSpace.Item(i).ObjectName = "AcDbPolyline") And (InStr(1, ThisDrawing.ModelSpace.Item(i).Layer, "首曲线") > 0 Or InStr(1, ThisDrawing.ModelSpace.Item(i).Layer, "计曲线") > 0) Then '41、Index 是图层名称,需要根据实际情况修改
Set ele1 = ThisDrawing.ModelSpace.Item(i) ' 多段线
get3Dpts = ele1.Coordinates
astr = ""
For j = LBound(get3Dpts, 1) To UBound(get3Dpts, 1) - 1 Step 2
index = index + 1
astr = astr + vbCrLf + FormatNumber(get3Dpts(j), 2, vbFalse, vbFalse, vbFalse) + " " + FormatNumber(get3Dpts(j + 1), 2, vbFalse, vbFalse, vbFalse) + " " + Str(ele1.Elevation)
Next j
Print #1, astr
End If
Next i
Close #1
End Sub