[分享]闲来无事，写了这个编号的程序

gzy

搞来玩的，望各位大侠指点一二。 'by gzy
'gzy@mjtd.com Dim Nums As Integer Sub Numbers()
Nums = 1
Dim keyWord As String
ThisDrawing.Utility.InitializeUserInput 0, "y n"
keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "编号是否带圈[否(N)/是(Y)][N]: ")

If keyWord = "" Then
keyWord = "N"
Call Ncircle
Else
Call Cir
End If

If keyWord = "N" Then Call Ncircle
End Sub Sub Ncircle()
RETRY:
Dim PPck1 As Variant, PPck2 As Variant
Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim line2 As AcadLine
Dim ppt(0 To 2) As Double: Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double

On Error Resume Next
PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：")
If Err <> 0 Then
Err.Clear
ThisDrawing.Utility.Prompt " 没有指定零件,退出"
Exit Sub
End If
PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")
If Err <> 0 Then
Err.Clear
ThisDrawing.Utility.Prompt " 没有指定编号位置,退出"
Exit Sub
End If
Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)
TextHeight = ThisDrawing.GetVariable("dimtxt") '沿用系统文字高度

If pd(PPck1, PPck2) = True Then
ppt(0) = PPck2(0) - 2 * TextHeight: ppt(1) = PPck2(1): ppt(2) = PPck2(2)
Else
ppt(0) = PPck2(0) + 2 * TextHeight: ppt(1) = PPck2(1): ppt(2) = PPck2(2)
End If

Set line2 = ThisDrawing.ModelSpace.AddLine(PPck2, ppt)
line2.Lineweight = acLnWt030
ThisDrawing.SendCommand "_LWDISPLAY" & vbCr & "on" & vbCr '显示线宽

Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:")
If Numbers1 = "" Then Numbers1 = Nums
If pd(PPck1, PPck2) = True Then
Inserpt(0) = ppt(0) + 0.5 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)
Else
Inserpt(0) = ppt(0) - 1.5 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)
End If
Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)
Nums = Numbers1 '使提示与上一编号关联
Nums = Nums + 1
GoTo RETRY
End Sub Sub Cir()
RETRY:
Dim PPck1 As Variant, PPck2 As Variant
Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim Cirobj As AcadCircle
Dim ppt(0 To 2) As Double: Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double

On Error Resume Next
PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：")
If Err <> 0 Then
Err.Clear
ThisDrawing.Utility.Prompt " 没有指定零件,退出"
Exit Sub
End If
PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")
If Err <> 0 Then
Err.Clear
ThisDrawing.Utility.Prompt " 没有指定编号位置,退出"
Exit Sub
End If
Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)
TextHeight = ThisDrawing.GetVariable("dimtxt") '沿用系统文字高度
ppt(0) = PPck2(0) + 0.7 * TextHeight: ppt(1) = PPck2(1) - 0.5 * TextHeight: ppt(2) = PPck2(2)
Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck2, TextHeight)
PPck2 = Cirobj.IntersectWith(line1, acExtendNone) '求交点
line1.EndPoint = PPck2 '剪切引线

Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:")
If Numbers1 = "" Then Numbers1 = Nums
If Len(Numbers1) = 2 Then
Inserpt(0) = ppt(0) - 1.4 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)
End If
If Len(Numbers1) = 1 Then
Inserpt(0) = ppt(0) - TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)
End If

Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)

Nums = Numbers1 '使提示与上一编号关联
Nums = Nums + 1
GoTo RETRY
End Sub
Function pd(p1 As Variant, p2 As Variant) As Boolean '判断斜率，以便确定文字位置
If p1(0) > p2(0) And p1(0) > p2(0) Then
pd = True
Else
pd = False
End If
End Function

puzb2023

希望楼主经常没事，多多写写这种好程序

Klein

这是用的VBA不是LISP，只能大体看懂

雪山飞狐_lzh

1. PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")

复制代码

这里改成

1. PPck2 = ThisDrawing.Utility.GetPoint(PPck1, "请指定编号位置：")

复制代码

要好些吧

mikewolf2k

精神可嘉！我虽然用不着，相信对用得上的人是很实用的。

ljcgq

楼上说的有道理，支持

mccad

最好能把画好的内容编成组合，这样方便选择。

gzy

各位的意见已收到！改进后再贴上来！

gzy

加了一点对文字定位的内容，群组了编号内容。

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

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

myfreemind

不错，挺实用的！

2002-ytf

我用的编号:



下带横线的,可加前后缀--如给水立管JL-1B         JL-2B ...;横线不加粗





多数不要引线但可加前后缀--如井号JL-1a         JL-2a ...

woshiyu121

我觉得你的发明很好，我画图时用的上，但是我是一个菜鸟，能否将你的发明发一个给我，并告诉我，最笨的安装方法！谢谢了！我的E ：woshiyu1217@126.com