|
|
1,关于取多边形各顶点坐标(引用帖子)
这是老大的经典程序，看看你就明白了！
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
请问取得的坐标有何规律?可否人为限制从某一点开始,按顺时钟或逆时钟取坐标?
2,怎样在vba中使用打开或保存文件对话框?(即commondialogbox)
3,我现在有一图形中多段线总是显示为空心的双线,是不是哪里设置不对?(别人做的图) |
|
置顶卡
