[VBA函数]：闲来无事，作了一个图纸的编号程序。

guanzhangyang

受efan2000的指点，特将代码贴出，以表感谢！呵呵！
  望各位提点意见！

2. 
   
3. 'by gzy
   
4. 'gzy@mjtd.com
   
5. 'scuta**可供个人使用，但不得转载
   
6. Dim Nums As Integer
   
7. Sub Numbers()
   
8. Nums = 1
   
9. Dim keyWord As String
   
10.     ThisDrawing.Utility.InitializeUserInput 0, "y n"
    
11.     keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "编号是否带圈[否(N)/是(Y)][N]: ")
    
12.    
    
13.     If keyWord = "" Then
    
14.       keyWord = "N"
    
15.       Call Ncircle
    
16.     Else
    
17.       Call Cir
    
18.     End If
    
19.    
    
20.     If keyWord = "N" Then Call Ncircle
    
21. End Sub
    
22. 
    
23. Sub Ncircle()
    
24. RETRY:
    
25.     Dim PPck1 As Variant, PPck2 As Variant
    
26.     Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim line2 As AcadLine
    
27.     Dim ppt(0 To 2) As Double:  Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double
    
28.    
    
29.      On Error Resume Next
    
30.     '  ThisDrawing.GetVariable ("osnap")
    
31.      PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：")
    
32.          If Err <> 0 Then
    
33.                 Err.Clear
    
34.                 ThisDrawing.Utility.Prompt " 没有指定零件,退出"
    
35.                 Exit Sub
    
36.           End If
    
37.      PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")
    
38.         If Err <> 0 Then
    
39.                 Err.Clear
    
40.                 ThisDrawing.Utility.Prompt " 没有指定编号位置,退出"
    
41.                 Exit Sub
    
42.           End If
    
43.   Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)
    
44.   TextHeight = ThisDrawing.GetVariable("dimtxt") '沿用系统文字高度
    
45.   
    
46.   If pd(PPck1, PPck2) = True Then
    
47.        ppt(0) = PPck2(0) - 2 * TextHeight:   ppt(1) = PPck2(1):    ppt(2) = PPck2(2)
    
48.   Else
    
49.        ppt(0) = PPck2(0) + 2 * TextHeight:   ppt(1) = PPck2(1):    ppt(2) = PPck2(2)
    
50.   End If
    
51.   
    
52.   Set line2 = ThisDrawing.ModelSpace.AddLine(PPck2, ppt)
    
53.   line2.Lineweight = acLnWt030
    
54.   ThisDrawing.SendCommand "_LWDISPLAY" & vbCr & "on" & vbCr   '显示线宽
    
55.       
    
56.   Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:")
    
57.   If Numbers1 = "" Then Numbers1 = Nums
    
58.   If pd(PPck1, PPck2) = True Then
    
59.     If Len(Numbers1) = 1 Then
    
60.       Inserpt(0) = ppt(0) + 0.6 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)
    
61.     Else
    
62.       Inserpt(0) = ppt(0) + 0.1 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)
    
63.     End If
    
64.   Else
    
65.      If Len(Numbers1) = 1 Then
    
66.       Inserpt(0) = ppt(0) - 1.2 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)
    
67.      Else
    
68.        Inserpt(0) = ppt(0) - 1.8 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)
    
69.      End If
    
70.   End If
    
71.      Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)
    
72.     Nums = Numbers1 '使提示与上一编号关联
    
73.     Nums = Nums + 1
    
74. Dim Group1 As AcadGroup
    
75. Dim objgroup(0 To 2) As AcadEntity
    
76. Set objgroup(0) = line1
    
77. Set objgroup(1) = line2
    
78. Set objgroup(2) = textobject(0)
    
79. Set Group1 = ThisDrawing.Groups.Add("*")
    
80. Group1.AppendItems objgroup
    
81. 
    
82. GoTo RETRY
    
83. End Sub
    
84. 
    
85. Sub Cir()
    
86. RETRY:
    
87.     Dim PPck1 As Variant, PPck2 As Variant
    
88.     Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim Cirobj As AcadCircle
    
89.     Dim ppt(0 To 2) As Double:  Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double
    
90.    
    
91.      On Error Resume Next
    
92.      PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：")
    
93.          If Err <> 0 Then
    
94.                 Err.Clear
    
95.                 ThisDrawing.Utility.Prompt " 没有指定零件,退出"
    
96.                 Exit Sub
    
97.           End If
    
98.      PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")
    
99.         If Err <> 0 Then
    
100.                 Err.Clear
     
101.                 ThisDrawing.Utility.Prompt " 没有指定编号位置,退出"
     
102.                 Exit Sub
     
103.           End If
     
104.   Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)
     
105.   TextHeight = ThisDrawing.GetVariable("dimtxt") '沿用系统文字高度
     
106.   ppt(0) = PPck2(0) + 0.7 * TextHeight: ppt(1) = PPck2(1) - 0.5 * TextHeight: ppt(2) = PPck2(2)
     
107.   Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck2, 1.2 * TextHeight)
     
108.     PPck2 = Cirobj.IntersectWith(line1, acExtendNone) '求交点
     
109.     line1.EndPoint = PPck2   '剪切引线
     
110.       
     
111.     Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "限于输入二位数字" & vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:")
     
112.     If Numbers1 = "" Then Numbers1 = Nums
     
113.     If Len(Numbers1) = 2 Then
     
114.       Inserpt(0) = ppt(0) - 1.5 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)
     
115.     End If
     
116.     If Len(Numbers1) = 1 Then
     
117.      Inserpt(0) = ppt(0) - TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)
     
118.     End If
     
119.    
     
120.     Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)
     
121.    
     
122.     Nums = Numbers1 '使提示与上一编号关联
     
123.     Nums = Nums + 1
     
124. Dim Group2 As AcadGroup
     
125. Dim objgroup(0 To 2) As AcadEntity
     
126. Set objgroup(0) = line1
     
127. Set objgroup(1) = Cirobj
     
128. Set objgroup(2) = textobject(0)
     
129. Set Group1 = ThisDrawing.Groups.Add("*")
     
130. Group1.AppendItems objgroup
     
131. 
     
132. GoTo RETRY
     
133. End Sub
     
134. Function pd(p1 As Variant, p2 As Variant) As Boolean '判断斜率，以便确定文字位置
     
135.     If p1(0) > p2(0) Then
     
136.       pd = True
     
137.     Else
     
138.       pd = False
     
139.     End If
     
140. End Function
     

<br /> 'by gzy<br /> 'gzy@mjtd.com<br /> 'scuta**可供个人使用，但不得转载<br /> Dim Nums As Integer<br /> Sub Numbers()<br /> Nums = 1<br /> Dim keyWord As String<br />     ThisDrawing.Utility.InitializeUserInput 0, "y n"<br />     keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "编号是否带圈[否(N)/是(Y)][N]: ")<br />     <br />     If keyWord = "" Then<br />       keyWord = "N"<br />       Call Ncircle<br />     Else<br />       Call Cir<br />     End If<br />     <br />     If keyWord = "N" Then Call Ncircle<br /> End Sub<br /> <br /> Sub Ncircle()<br /> RETRY:<br />     Dim PPck1 As Variant, PPck2 As Variant<br />     Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim line2 As AcadLine<br />     Dim ppt(0 To 2) As Double:  Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double<br />     <br />      On Error Resume Next<br />     '  ThisDrawing.GetVariable ("osnap")<br />      PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：")<br />          If Err <> 0 Then<br />                 Err.Clear<br />                 ThisDrawing.Utility.Prompt " 没有指定零件,退出"<br />                 Exit Sub<br />           End If<br />      PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")<br />         If Err <> 0 Then<br />                 Err.Clear<br />                 ThisDrawing.Utility.Prompt " 没有指定编号位置,退出"<br />                 Exit Sub<br />           End If<br />   Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)<br />   TextHeight = ThisDrawing.GetVariable("dimtxt") '沿用系统文字高度<br />   <br />   If pd(PPck1, PPck2) = True Then<br />        ppt(0) = PPck2(0) - 2 * TextHeight:   ppt(1) = PPck2(1):    ppt(2) = PPck2(2)<br />   Else<br />        ppt(0) = PPck2(0) + 2 * TextHeight:   ppt(1) = PPck2(1):    ppt(2) = PPck2(2)<br />   End If<br />   <br />   Set line2 = ThisDrawing.ModelSpace.AddLine(PPck2, ppt)<br />   line2.Lineweight = acLnWt030<br />   ThisDrawing.SendCommand "_LWDISPLAY" & vbCr & "on" & vbCr   '显示线宽<br />       <br />   Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:")<br />   If Numbers1 = "" Then Numbers1 = Nums<br />   If pd(PPck1, PPck2) = True Then<br />     If Len(Numbers1) = 1 Then<br />       Inserpt(0) = ppt(0) + 0.6 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)<br />     Else<br />       Inserpt(0) = ppt(0) + 0.1 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)<br />     End If<br />   Else<br />      If Len(Numbers1) = 1 Then<br />       Inserpt(0) = ppt(0) - 1.2 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)<br />      Else<br />        Inserpt(0) = ppt(0) - 1.8 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)<br />      End If<br />   End If<br />      Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)<br />     Nums = Numbers1 '使提示与上一编号关联<br />     Nums = Nums + 1<br /> Dim Group1 As AcadGroup<br /> Dim objgroup(0 To 2) As AcadEntity<br /> Set objgroup(0) = line1<br /> Set objgroup(1) = line2<br /> Set objgroup(2) = textobject(0)<br /> Set Group1 = ThisDrawing.Groups.Add("*")<br /> Group1.AppendItems objgroup<br /> <br /> GoTo RETRY<br /> End Sub<br /> <br /> Sub Cir()<br /> RETRY:<br />     Dim PPck1 As Variant, PPck2 As Variant<br />     Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim Cirobj As AcadCircle<br />     Dim ppt(0 To 2) As Double:  Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double<br />     <br />      On Error Resume Next<br />      PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：")<br />          If Err <> 0 Then<br />                 Err.Clear<br />                 ThisDrawing.Utility.Prompt " 没有指定零件,退出"<br />                 Exit Sub<br />           End If<br />      PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")<br />         If Err <> 0 Then<br />                 Err.Clear<br />                 ThisDrawing.Utility.Prompt " 没有指定编号位置,退出"<br />                 Exit Sub<br />           End If<br />   Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)<br />   TextHeight = ThisDrawing.GetVariable("dimtxt") '沿用系统文字高度<br />   ppt(0) = PPck2(0) + 0.7 * TextHeight: ppt(1) = PPck2(1) - 0.5 * TextHeight: ppt(2) = PPck2(2)<br />   Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck2, 1.2 * TextHeight)<br />     PPck2 = Cirobj.IntersectWith(line1, acExtendNone) '求交点<br />     line1.EndPoint = PPck2   '剪切引线<br />       <br />     Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "限于输入二位数字" & vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:")<br />     If Numbers1 = "" Then Numbers1 = Nums<br />     If Len(Numbers1) = 2 Then<br />       Inserpt(0) = ppt(0) - 1.5 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)<br />     End If<br />     If Len(Numbers1) = 1 Then<br />      Inserpt(0) = ppt(0) - TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)<br />     End If<br />     <br />     Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)<br />     <br />     Nums = Numbers1 '使提示与上一编号关联<br />     Nums = Nums + 1<br /> Dim Group2 As AcadGroup<br /> Dim objgroup(0 To 2) As AcadEntity<br /> Set objgroup(0) = line1<br /> Set objgroup(1) = Cirobj<br /> Set objgroup(2) = textobject(0)<br /> Set Group1 = ThisDrawing.Groups.Add("*")<br /> Group1.AppendItems objgroup<br /> <br /> GoTo RETRY<br /> End Sub<br /> Function pd(p1 As Variant, p2 As Variant) As Boolean '判断斜率，以便确定文字位置<br />     If p1(0) > p2(0) Then<br />       pd = True<br />     Else<br />       pd = False<br />     End If<br /> End Function<br />

yfy2003

不错!
还实用!

jinfu2908

这位大哥，小弟我遇到了一些难题，这关系到小弟的学业。
问题是这样的：我要编一个绘制液压原理图的程序，是二维的，我的任务要求是实现原理图中各个液压阀件的自动连线。关键问题是连线时所要连的线要自动绕开阀件（插入的块）要求用VBA编，希望大哥能帮小弟解决这个难题，能给小弟一个自动连线并绕开障碍区（阀件）的源程序，小弟将不胜感激！！！！！！小弟在此先谢谢大哥了！！！谢谢！