增加新的AutoCAD延长直线的功能

pbh1974

AutoCAD中的延长直线的命令需要先制定边界，再延长，用VBA可以编写一个直接用鼠标来确定延长位置的程序，可谓鼠标指到哪儿，直线就延长到哪儿，再也不用事先画边界了。有兴趣的同行可以给我发E－mail要求源程序。

mccad

Hart

最好也能延长圆弧，只能延长直线对绘图帮助不是很大，因为要记两个命令。

pbh1974

当然可以延长圆弧，对原来延长直线的程序加以修改即可，但要用VBA来实现动态的拖动，本人还没有找到相应的VBA函数，希望高手提供帮助！

mccad

pbh1974

好办法！！！！

pbh1974

Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Public Function MyHotKey(vKeyCode) As Boolean
MyHotKey = (GetAsyncKeyState(vKeyCode) < 0)
End Function

Public Sub ExtendLineArc()
Dim Object1 As AcadObject, Line2 As AcadLine, Line3 As AcadLine
Dim FP As Variant, TP As Variant, OutAngle As Double, kk As Integer
Dim P1(0 To 2) As Double, P2(0 To 2) As Double, RetP As Variant, SelectBase As Variant
Dim ComS As String
On Error Resume Next

LLL1:
    ThisDrawing.Utility.GetEntity Object1, SelectBase, "选择需要延长的直线或圆弧："
    If Err Then
        If MyHotKey(vbKeyEscape) Then
            Err.Clear
            Exit Sub
        End If
        ThisDrawing.Utility.Prompt "没有选择实体!"
        Err.Clear
        GoTo LLL1
    ElseIf Object1.ObjectName = "AcDbLine" Then
        Object1.Highlight True
        RetP = ThisDrawing.Utility.GetPoint(, "延长的位置：")
        P1(0) = RetP(0) + 50 * Cos(Object1.Angle + Pt / 2)
        P1(1) = RetP(1) + 50 * Sin(Object1.Angle + Pt / 2)
        P2(0) = RetP(0) + 50 * Cos(Object1.Angle - Pt / 2)
        P2(1) = RetP(1) + 50 * Sin(Object1.Angle - Pt / 2)
   
        FP = Object1.StartPoint: TP = Object1.EndPoint
        RetP = Per_Inter(P1(0), P1(1), P2(0), P2(1), FP(0), FP(1))
        If CalDis(RetP(0), RetP(1), FP(0), FP(1)) > CalDis(RetP(0), RetP(1), TP(0), TP(1)) Then
            P1(0) = RetP(0): P1(1) = RetP(1)
            P2(0) = FP(0):   P2(1) = FP(1)
            Set Line2 = ThisDrawing.ModelSpace.AddLine(P1, P2)
            Line2.Color = Object1.Color:      Object1.Delete
        Else
            P1(0) = RetP(0): P1(1) = RetP(1)
            P2(0) = TP(0):   P2(1) = TP(1)
            Object1
            Set Line2 = ThisDrawing.ModelSpace.AddLine(P1, P2)
            Line2.Color = Object1.Color:      Object1.Delete
        End If
        Object1.Highlight False
        Err.Clear
        GoTo LLL1
    ElseIf Object1.ObjectName = "AcDbArc" Then
        Dim Line1 As AcadLine
        Dim SAngle As Double, EAngle As Double, DDAngle As Double, Angle1 As Double, Angle2 As Double
        Object1.Highlight True
        RetP = ThisDrawing.Utility.GetPoint(, "延长的位置:")
        Dim Arc1 As AcadArc, arc2 As AcadCircle
        If Distance(RetP, Object1.StartPoint) < 0.0000001 Or Distance(RetP, Object1.EndPoint) < 0.0000001 Then
            FP = Object1.center
            Set arc2 = ThisDrawing.ModelSpace.AddCircle(FP, Object1.radius)
            arc2.Color = Object1.Color: Object1.Delete
        ElseIf Distance(RetP, Object1.StartPoint) < Distance(RetP, Object1.EndPoint) Then
            SAngle = Object1.startAngle: EAngle = Object1.endAngle
            FP = Object1.center
            Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP)
                Angle2 = Line1.Angle: Line1.Delete
            TP = Object1.StartPoint
            Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP)
                Angle1 = Line1.Angle: Line1.Delete
            DDAngle = Angle2 - Angle1
            SAngle = SAngle + DDAngle
            Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius, SAngle, EAngle)
            Arc1.Color = Object1.Color: Object1.Delete
        Else
            SAngle = Object1.startAngle: EAngle = Object1.endAngle
            FP = Object1.center
            Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP)
                Angle2 = Line1.Angle: Line1.Delete
            TP = Object1.EndPoint
            Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP)
                Angle1 = Line1.Angle: Line1.Delete
            DDAngle = Angle2 - Angle1
            EAngle = EAngle + DDAngle
            Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius, SAngle, EAngle)
            Arc1.Color = Object1.Color: Object1.Delete
        End If
        'Object1.Highlight False
        Err.Clear
        GoTo LLL1
    Else
        ThisDrawing.Utility.Prompt "你选择的实体无法用本工具延长！"
        GoTo LLL1
    End If
End Sub