pbh1974 发表于 2002-12-30 10:51:00

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

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

mccad 发表于 2002-12-31 19:06:00

大家都有兴趣，最好是动态的

Hart 发表于 2003-1-2 10:26:00

最好也能延长圆弧，只能延长直线对绘图帮助不是很大。

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

pbh1974 发表于 2003-1-7 09:02:00

当然可以延长圆弧

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

mccad 发表于 2003-1-7 20:44:00

其实直接点线(或弧)的端点，通过对象追踪功能可以延长而不需写程序

pbh1974 发表于 2003-1-8 08:45:00

好办法！！！！

好办法！！！！

pbh1974 发表于 2003-1-9 17:13:00

源程序如下：。。。。。

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


页: [1]
查看完整版本: 增加新的AutoCAD延长直线的功能