|
|
[VBA]如何利用vba提取polyline中各顶点的坐标?亿万分感谢!
下面这段程序只能获得坐标，只能获得第一个点的高程，无法获得每个点的高程。
Sub RevPline()
Dim ent As AcadEntity
Dim pnt As Variant
Dim NewCoord() As Double
Dim i As Integer
On Error Resume Next
Do
ThisDrawing.Utility.GetEntity ent, pnt, "选择多段线："
If Err Then Exit Sub
If TypeName(ent) Like "IAcad*Polyline" Then Exit Do
Loop
Dim Coord As Variant
Dim CoordCount As Integer
Dim Bulge() As Double '凸度
If TypeName(ent) = "IAcadLWPolyline" Then
Coord = ent.Coordinates '获取顶点坐标数组
CoordCount = (UBound(Coord) + 1) / 2 '顶点数
'定义新的顶点坐标数组
ReDim NewCoord(UBound(Coord)) As Double
For i = 0 To UBound(Coord) - 1 Step 2
NewCoord(UBound(Coord) - i - 1) = Coord(i)
NewCoord(UBound(Coord) - i) = Coord(i + 1)
Next
ReDim Bulge(CoordCount - 1) As Double
For i = 0 To CoordCount - 1
Bulge(i) = ent.GetBulge(i)
Next
ent.Coordinates = NewCoord
For i = 0 To CoordCount - 2
ent.SetBulge i, -Bulge(CoordCount - 2 - i)
Next
ThisDrawing.Regen acActiveViewport
ElseIf TypeName(ent) = "IAcadPolyline" Then
Coord = ent.Coordinates
CoordCount = (UBound(Coord) + 1) / 3
ReDim NewCoord(UBound(Coord)) As Double
For i = 0 To UBound(Coord) - 1 Step 3
NewCoord(UBound(Coord) - i - 2) = Coord(i)
NewCoord(UBound(Coord) - i - 1) = Coord(i + 1)
NewCoord(UBound(Coord) - i) = Coord(i + 2)
Next
If ent.Type = acSimplePoly Then
ReDim Bulge(CoordCount - 1) As Double
For i = 0 To CoordCount - 1
Bulge(i) = ent.GetBulge(i)
Next
End If
ent.Coordinates = NewCoord
If ent.Type = acSimplePoly Then
For i = 0 To CoordCount - 2
ent.SetBulge i, -Bulge(CoordCount - 2 - i)
Next
End If
ThisDrawing.Regen acActiveViewport
End If
End Sub
|
|
置顶卡
