[VBA]如何利用vba提取polyline中各顶点的坐标?亿万分感谢!
如何利用vba提取polyline中各顶点的坐标? coordinate属性 h_lon发表于2003-12-15 18:52:00static/image/common/back.gif如何利用vba提取polyline中各顶点的坐标?亿万分感谢!如何利用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 谢谢诸位大侠!
页:
[1]