AutoCAD VBA多段线操作

多段线操作，代码如下。

Private Function GetVertexCount(ByVal objPline As AcadEntity) As Long
If TypeOf objPline Is AcadLWPolyline Then
GetVertexCount = (UBound(objPline.Coordinates) + 1) / 2
ElseIf TypeOf objPline Is AcadPolyline Then
GetVertexCount = (UBound(objPline.Coordinates) + 1) / 3
End If
End Function
Public Sub JoinPoly()
On Error Resume Next
Dim SSet As AcadSelectionSet
If Not IsNull(ThisDrawing.SelectionSets.Item("JoinPoly")) Then
Set SSet = ThisDrawing.SelectionSets.Item("JoinPoly")
SSet.Delete
End If
Set SSet = ThisDrawing.SelectionSets.Add("JoinPoly")
SSet.SelectOnScreen
Dim det As String
det = axSSet2lspEnts(SSet)
SSet.Delete
ThisDrawing.SendCommand "_pedit" & vbCr & "M" & vbCr & det & vbCr & vbCr & "J" & vbCr & vbCr & vbCr
End Sub
Public Function axSSet2lspEnts(ByVal SSet As AcadSelectionSet) As String
If SSet.Count = 0 Then Exit Function
Dim entHandle As String
Dim strEnts As String
entHandle = SSet.Item(0).Handle
strEnts = "(handent" & Chr(34) & entHandle & Chr(34) & ")"
If SSet.Count > 1 Then
Dim i As Integer
For i = 1 To SSet.Count - 1
entHandle = SSet.Item(i).Handle
strEnts = strEnts & vbCr & "(handent" & Chr(34) & entHandle & Chr(34) & ")"
Next i
End If
acSSet2lspEnts = strEnts
End Function
Public Sub ClickAddPolyline()
Dim n As Long
n = ThisDrawing.ModelSpace.Count
Dim pt As Variant
pt = ThisDrawing.Utility.GetPoint(, "指定内部点：")
ThisDrawing.SendCommand "-Boundary" & vbCr & pt(0) & "," & pt(1) & vbCr & vbCr
Dim objPoly As AcadLWPolyline
If ThisDrawing.ModelSpace.Count > 1 Then
Set objPoly = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
objPoly.color = acRed
Else
MsgBox "未发现边界。"
End If
End Sub
Private Function GetAllBulges(ByVal objPoly As AcadEntity) As Collection
If TypeOf objPoly Is AcadLWPolyline Or TypeOf objPoly Is AcadPolyline Then
Dim bulgeCollection As New Collection
Dim i As Long
For i = 0 To GetVertexCount(objPoly) - 1
bulgeCollection.Add objPoly.GetBulge(i)
Next i
Set GetAllBulges = bulgeCollection
Else
MsgBox "objPoly不是多段线!"
End Function
Private Function RevCollection(ByVal bulgeCollection As Collection) As Collection
Dim newCollection As New Collection
Dim i As Long
For i = 1 To bulgeCollection.Count
Dim bulge As Double
bulge = bulgeCollection.Item(bulgeCollection.Count + 1 - i)
If bulge <> 0 Then
newCollection.Add -bulgeCollection.Item(bulgeCollection.Count + 1 - i)
Else
newCollection.Add 0
End If
Next i
Set RevCollection = newCollection
End Function
Private Sub SetAllBulges(ByVal objPoly As AcadEntity, ByVal bulgeCollection As Collection)
If TypeOf objPoly Is AcadLWPolyline Or TypeOf objPoly Is AcadPolyline Then
Dim i As Long
For i = 0 To GetVertexCount(objPoly) - 1
objPoly.SetBulge i, bulgeCollection(i + 1)
Next i
Else
MsgBox "objPol不是多段线！"
End If
End Sub
Public 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
If TypeOf ent Is AcadLWPolyline Then
Coord = ent.Coordinates
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
ElseIf TypeOf ent Is AcadPolyline Then
Coord = ent.Coordinates
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
End If
ent.Coordinates = NewCoord
Dim bulgeCollection As New Collection
Set bulgeCollection = GetAllBulges(ent)
bulgeCollection.Remove bulgeCollection.Count
bulgeCollection.Add 0, , 1
Dim newbulges As New Collection
Set newbulges = RevCollection(bulgeCollection)
Call SetAllBulges(ent, newbulges)
ThisDrawing.Regen acActiveViewport
End
End Sub
Public Sub testvertexcount()
Dim objSelect As Object
Dim ptPick As Variant
ThisDrawing.Utility.GetEntity objSelect, ptPick, "选择多段线："
If TypeOf objSelect Is AcadLWPolyline Then
MsgBox GetVertexCount(objSelect)
End If
End Sub

代码完。