[VBA程序]：增加新的AutoCAD延长直线的功能

wowoaicad

从别处看到的转贴过来，详细可去明径通道。
增加新的AutoCAD延长直线的功能
AutoCAD中的延长直线的命令需要先制定边界，再延长，用VBA可以编写一个直接用鼠标来确定延长位置的程序，可谓鼠标指到哪儿，直线就延长到哪儿，再也不用事先画边界了。

2. 源程序如下：。。。。。
   
3. Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
   
4. 
   
5. Public Function MyHotKey(vKeyCode) As Boolean
   
6. MyHotKey = (GetAsyncKeyState(vKeyCode) < 0)
   
7. End Function
   
8. 
   
9. Public Sub ExtendLineArc()
   
10. Dim Object1 As AcadObject, Line2 As AcadLine, Line3 As AcadLine
    
11. Dim FP As Variant, TP As Variant, OutAngle As Double, kk As Integer
    
12. Dim P1(0 To 2) As Double, P2(0 To 2) As Double, RetP As Variant, SelectBase As Variant
    
13. Dim ComS As String
    
14. On Error Resume Next
    
15. 
    
16. LLL1:
    
17.     ThisDrawing.Utility.GetEntity Object1, SelectBase, "选择需要延长的直线或圆弧："
    
18.     If Err Then
    
19.         If MyHotKey(vbKeyEscape) Then
    
20.             Err.Clear
    
21.             Exit Sub
    
22.         End If
    
23.         ThisDrawing.Utility.Prompt "没有选择实体!"
    
24.         Err.Clear
    
25.         GoTo LLL1
    
26.     ElseIf Object1.ObjectName = "AcDbLine" Then
    
27.         Object1.Highlight True
    
28.         RetP = ThisDrawing.Utility.GetPoint(, "延长的位置：")
    
29.         P1(0) = RetP(0) + 50 * Cos(Object1.Angle + Pt / 2)
    
30.         P1(1) = RetP(1) + 50 * Sin(Object1.Angle + Pt / 2)
    
31.         P2(0) = RetP(0) + 50 * Cos(Object1.Angle - Pt / 2)
    
32.         P2(1) = RetP(1) + 50 * Sin(Object1.Angle - Pt / 2)
    
33.      
    
34.         FP = Object1.StartPoint: TP = Object1.EndPoint
    
35.         RetP = Per_Inter(P1(0), P1(1), P2(0), P2(1), FP(0), FP(1))
    
36.         If CalDis(RetP(0), RetP(1), FP(0), FP(1)) > CalDis(RetP(0), RetP(1), TP(0), TP(1)) Then
    
37.             P1(0) = RetP(0): P1(1) = RetP(1)
    
38.             P2(0) = FP(0):   P2(1) = FP(1)
    
39.             Set Line2 = ThisDrawing.ModelSpace.AddLine(P1, P2)
    
40.             Line2.Color = Object1.Color:      Object1.Delete
    
41.         Else
    
42.             P1(0) = RetP(0): P1(1) = RetP(1)
    
43.             P2(0) = TP(0):   P2(1) = TP(1)
    
44.             Object1
    
45.             Set Line2 = ThisDrawing.ModelSpace.AddLine(P1, P2)
    
46.             Line2.Color = Object1.Color:      Object1.Delete
    
47.         End If
    
48.         Object1.Highlight False
    
49.         Err.Clear
    
50.         GoTo LLL1
    
51.     ElseIf Object1.ObjectName = "AcDbArc" Then
    
52.         Dim Line1 As AcadLine
    
53.         Dim SAngle As Double, EAngle As Double, DDAngle As Double, Angle1 As Double, Angle2 As Double
    
54.         Object1.Highlight True
    
55.         RetP = ThisDrawing.Utility.GetPoint(, "延长的位置:")
    
56.         Dim Arc1 As AcadArc, arc2 As AcadCircle
    
57.         If Distance(RetP, Object1.StartPoint) < 0.0000001 Or Distance(RetP, Object1.EndPoint) < 0.0000001 Then
    
58.             FP = Object1.center
    
59.             Set arc2 = ThisDrawing.ModelSpace.AddCircle(FP, Object1.radius)
    
60.             arc2.Color = Object1.Color: Object1.Delete
    
61.         ElseIf Distance(RetP, Object1.StartPoint) < Distance(RetP, Object1.EndPoint) Then
    
62.             SAngle = Object1.startAngle: EAngle = Object1.endAngle
    
63.             FP = Object1.center
    
64.             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP)
    
65.                 Angle2 = Line1.Angle: Line1.Delete
    
66.             TP = Object1.StartPoint
    
67.             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP)
    
68.                 Angle1 = Line1.Angle: Line1.Delete
    
69.             DDAngle = Angle2 - Angle1
    
70.             SAngle = SAngle + DDAngle
    
71.             Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius, SAngle, EAngle)
    
72.             Arc1.Color = Object1.Color: Object1.Delete
    
73.         Else
    
74.             SAngle = Object1.startAngle: EAngle = Object1.endAngle
    
75.             FP = Object1.center
    
76.             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP)
    
77.                 Angle2 = Line1.Angle: Line1.Delete
    
78.             TP = Object1.EndPoint
    
79.             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP)
    
80.                 Angle1 = Line1.Angle: Line1.Delete
    
81.             DDAngle = Angle2 - Angle1
    
82.             EAngle = EAngle + DDAngle
    
83.             Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius, SAngle, EAngle)
    
84.             Arc1.Color = Object1.Color: Object1.Delete
    
85.         End If
    
86.         'Object1.Highlight False
    
87.         Err.Clear
    
88.         GoTo LLL1
    
89.     Else
    
90.         ThisDrawing.Utility.Prompt "你选择的实体无法用本工具延长！"
    
91.         GoTo LLL1
    
92.     End If
    
93. End Sub
    

源程序如下：。。。。。<br /> Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer <br /> <br /> Public Function MyHotKey(vKeyCode) As Boolean <br /> MyHotKey = (GetAsyncKeyState(vKeyCode) < 0) <br /> End Function <br /> <br /> Public Sub ExtendLineArc() <br /> Dim Object1 As AcadObject, Line2 As AcadLine, Line3 As AcadLine <br /> Dim FP As Variant, TP As Variant, OutAngle As Double, kk As Integer <br /> Dim P1(0 To 2) As Double, P2(0 To 2) As Double, RetP As Variant, SelectBase As Variant <br /> Dim ComS As String <br /> On Error Resume Next <br /> <br /> LLL1: <br />     ThisDrawing.Utility.GetEntity Object1, SelectBase, "选择需要延长的直线或圆弧：" <br />     If Err Then <br />         If MyHotKey(vbKeyEscape) Then <br />             Err.Clear <br />             Exit Sub <br />         End If <br />         ThisDrawing.Utility.Prompt "没有选择实体!" <br />         Err.Clear <br />         GoTo LLL1 <br />     ElseIf Object1.ObjectName = "AcDbLine" Then <br />         Object1.Highlight True <br />         RetP = ThisDrawing.Utility.GetPoint(, "延长的位置：") <br />         P1(0) = RetP(0) + 50 * Cos(Object1.Angle + Pt / 2) <br />         P1(1) = RetP(1) + 50 * Sin(Object1.Angle + Pt / 2) <br />         P2(0) = RetP(0) + 50 * Cos(Object1.Angle - Pt / 2) <br />         P2(1) = RetP(1) + 50 * Sin(Object1.Angle - Pt / 2) <br />      <br />         FP = Object1.StartPoint: TP = Object1.EndPoint <br />         RetP = Per_Inter(P1(0), P1(1), P2(0), P2(1), FP(0), FP(1)) <br />         If CalDis(RetP(0), RetP(1), FP(0), FP(1)) > CalDis(RetP(0), RetP(1), TP(0), TP(1)) Then <br />             P1(0) = RetP(0): P1(1) = RetP(1) <br />             P2(0) = FP(0):   P2(1) = FP(1) <br />             Set Line2 = ThisDrawing.ModelSpace.AddLine(P1, P2) <br />             Line2.Color = Object1.Color:      Object1.Delete <br />         Else <br />             P1(0) = RetP(0): P1(1) = RetP(1) <br />             P2(0) = TP(0):   P2(1) = TP(1) <br />             Object1 <br />             Set Line2 = ThisDrawing.ModelSpace.AddLine(P1, P2) <br />             Line2.Color = Object1.Color:      Object1.Delete <br />         End If <br />         Object1.Highlight False <br />         Err.Clear <br />         GoTo LLL1 <br />     ElseIf Object1.ObjectName = "AcDbArc" Then <br />         Dim Line1 As AcadLine <br />         Dim SAngle As Double, EAngle As Double, DDAngle As Double, Angle1 As Double, Angle2 As Double <br />         Object1.Highlight True <br />         RetP = ThisDrawing.Utility.GetPoint(, "延长的位置:") <br />         Dim Arc1 As AcadArc, arc2 As AcadCircle <br />         If Distance(RetP, Object1.StartPoint) < 0.0000001 Or Distance(RetP, Object1.EndPoint) < 0.0000001 Then <br />             FP = Object1.center <br />             Set arc2 = ThisDrawing.ModelSpace.AddCircle(FP, Object1.radius) <br />             arc2.Color = Object1.Color: Object1.Delete <br />         ElseIf Distance(RetP, Object1.StartPoint) < Distance(RetP, Object1.EndPoint) Then <br />             SAngle = Object1.startAngle: EAngle = Object1.endAngle <br />             FP = Object1.center <br />             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP) <br />                 Angle2 = Line1.Angle: Line1.Delete <br />             TP = Object1.StartPoint <br />             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP) <br />                 Angle1 = Line1.Angle: Line1.Delete <br />             DDAngle = Angle2 - Angle1 <br />             SAngle = SAngle + DDAngle <br />             Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius, SAngle, EAngle) <br />             Arc1.Color = Object1.Color: Object1.Delete <br />         Else <br />             SAngle = Object1.startAngle: EAngle = Object1.endAngle <br />             FP = Object1.center <br />             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP) <br />                 Angle2 = Line1.Angle: Line1.Delete <br />             TP = Object1.EndPoint <br />             Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP) <br />                 Angle1 = Line1.Angle: Line1.Delete <br />             DDAngle = Angle2 - Angle1 <br />             EAngle = EAngle + DDAngle <br />             Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius, SAngle, EAngle) <br />             Arc1.Color = Object1.Color: Object1.Delete <br />         End If <br />         'Object1.Highlight False <br />         Err.Clear <br />         GoTo LLL1 <br />     Else <br />         ThisDrawing.Utility.Prompt "你选择的实体无法用本工具延长！" <br />         GoTo LLL1 <br />     End If <br /> End Sub <br />

efan2000

还缺少了几个函数Per_Inter、Distance、CalDis，其中Distance、CalDis这两个函数的作用是一样的，怎么不合并在一起。另外On Error Resume Next的使用也要注意，应尽早释放，以免后面的操作出错时程序将继续执行。
在CAD中可以直接选择实体，然后通过拖运热点来更改实体的长度和角度。但这种实践的精神是可取的。

lijiao

最初由 wowoaicad 发布
[B]从别处看到的转贴过来，详细可去明径通道。
增加新的AutoCAD延长直线的功能
AutoCAD中的延长直线的命令需要先制定边界，再延长，用VBA可以编写一个直接用鼠标来确定延长位置的程序，可谓鼠标指到哪儿，直线就延长?.. [/B]

这是我用LSP作的

flydyt

各位能不能上传代码.谢谢