[CASS二次开发源代码]VB6+AutoCAD多段线换向

时间：2019-11-14 08:21 作者：AcadApp 阅读：1111 评论：1

Windows10

其他

CASS9

Sub IReversal(ByVal AcadApp As Object) '多段线换向
    Dim ent As Object
    Dim pnt As Variant, NewCoord() As Double, i As Integer
    Dim Coord As Variant, CoordCount As Integer, Bulge() As Double
    On Error Resume Next
    AcadApp.Application.ActiveDocument.Utility.GetEntity ent, pnt, vbCr & vbCr & "指定多段线:"
    If Err Then Err.Clear: Exit Sub
    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
        AcadApp.Application.ActiveDocument.Regen 1
    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
        AcadApp.Application.ActiveDocument.Regen 1
    Else
        MsgBox "不支持的实体类型。", vbExclamation, "AutoCAD"
    End If
End Sub

全部评论

等级:LV30

积分:72050

奔跑蜗牛 2019-12-03 16:30

大神厉害

1