Autocad反转曲线方面
Sub reverse_sel()Dim ent_reverse As AcadObject
Dim count_unreverse As Long
Dim sel_set_reverse As AcadSelectionSet
On Error Resume Next
Set sel_set_reverse = ThisDrawing.SelectionSets.Item("reverse")
sel_set_reverse.Delete
Err.Clear
Set sel_set_reverse = ThisDrawing.SelectionSets.Add("reverse")
If Err Then Exit Sub
On Error GoTo 0
sel_set_reverse.SelectOnScreen
For Each ent_reverse In sel_set_reverse
Select Case ent_reverse.ObjectName
Case "AcDbPolyline", "AcDbArc", "AcDbLine", "AcDbCircle"
If reverse(ent_reverse) Then
ent_reverse.Delete
Else
count_unreverse = count_unreverse + 1
End If
Case Else
count_unreverse = count_unreverse + 1
End Select
Next
ThisDrawing.Utility.Prompt vbCrLf & sel_set_reverse.Count - count_unreverse & "个对象被反转。"
ThisDrawing.SendCommand Chr(27)
End Sub
Private Function reverse(ent_reverse As AcadObject) As Boolean
Dim coordinates_old As Variant
Dim coordinates_new() As Double
Dim radius As Double
Dim bound_up As Long
Dim index As Long
Dim color_ent As New AcadAcCmColor
Dim ent_polyline As AcadLWPolyline
Dim coordinate_start As Variant, coordinate_end As Variant, coordinate_center As Variant
Dim arr_bulge() As Double
Dim coord As Variant
reverse = True
Set color_ent = ent_reverse.TrueColor
If ent_reverse.ObjectName = "AcDbPolyline" Then
coordinates_old = ent_reverse.coordinates
If ent_reverse.Closed Then
bound_up = UBound(coordinates_old)
ReDim Preserve coordinates_old(bound_up + 2)
coordinates_old(bound_up + 1) = coordinates_old(0)
coordinates_old(bound_up + 2) = coordinates_old(1)
End If
bound_up = UBound(coordinates_old)
ReDim coordinates_new(LBound(coordinates_old) To bound_up) As Double
For index = bound_up To 0 Step -2
coordinates_new(bound_up - index) = coordinates_old(index - 1)
coordinates_new(bound_up - index + 1) = coordinates_old(index)
Next
Set ent_polyline = ThisDrawing.ModelSpace.AddLightWeightPolyline(coordinates_new)
For index = 0 To bound_up - 3 Step 2
ent_polyline.SetBulge (bound_up - 3 - index) / 2, -ent_reverse.GetBulge(Int(index / 2))
Next
ent_polyline.TrueColor = color_ent
ent_polyline.Update
Set ent_polyline = Nothing
ElseIf ent_reverse.ObjectName = "AcDbLine" Then
coordinate_start = ent_reverse.StartPoint
coordinate_end = ent_reverse.EndPoint
ReDim coordinates_new(0 To 3) As Double
coordinates_new(0) = coordinate_end(0)
coordinates_new(1) = coordinate_end(1)
coordinates_new(2) = coordinate_start(0)
coordinates_new(3) = coordinate_start(1)
Set ent_polyline = ThisDrawing.ModelSpace.AddLightWeightPolyline(coordinates_new)
ent_polyline.TrueColor = color_ent
Set ent_polyline = Nothing
ElseIf ent_reverse.ObjectName = "AcDbArc" Then
coordinate_start = ent_reverse.StartPoint
coordinate_end = ent_reverse.EndPoint
ReDim coordinates_new(0 To 3) As Double
coordinates_new(0) = coordinate_end(0)
coordinates_new(1) = coordinate_end(1)
coordinates_new(2) = coordinate_start(0)
coordinates_new(3) = coordinate_start(1)
Set ent_polyline = ThisDrawing.ModelSpace.AddLightWeightPolyline(coordinates_new)
ent_polyline.SetBulge 0, -Tan(ent_reverse.TotalAngle / 4)
ent_polyline.TrueColor = color_ent
Set ent_polyline = Nothing
ElseIf ent_reverse.ObjectName = "AcDbCircle" Then
coordinate_center = ent_reverse.Center
radius = ent_reverse.radius
ReDim coordinates_new(0 To 3) As Double
coordinates_new(0) = coordinate_center(0) + radius
coordinates_new(1) = coordinate_center(1)
coordinates_new(2) = coordinate_center(0) - radius
coordinates_new(3) = coordinate_center(1)
Set ent_polyline = ThisDrawing.ModelSpace.AddLightWeightPolyline(coordinates_new)
ent_polyline.Closed = True
ent_polyline.SetBulge 0, -1
ent_polyline.SetBulge 1, -1
ent_polyline.TrueColor = color_ent
Set ent_polyline = Nothing
Else
reverse = False
End If
End Function
页:
[1]