gzy 发表于 2004-5-11 18:12:00

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

搞来玩的，望各位大侠指点一二。






'by gzy<BR><A href="mailto:'gzy@mjtd.com" target="_blank" >'gzy@mjtd.com</A>


Dim Nums As Integer


Sub Numbers()<BR>Nums = 1<BR>Dim keyWord As String<BR>                       ThisDrawing.Utility.InitializeUserInput 0, "y n"<BR>                       keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf &amp; "编号是否带圈[否(N)/是(Y)]: ")<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


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>                               PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：")<BR>                                                               If Err &lt;&gt; 0 Then<BR>                                                                                                                       Err.Clear<BR>                                                                                                                       ThisDrawing.Utility.Prompt " 没有指定零件,退出"<BR>                                                                                                                       Exit Sub<BR>                                                                       End If<BR>                               PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")<BR>                                                       If Err &lt;&gt; 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" &amp; vbCr &amp; "on" &amp; vbCr               '显示线宽<BR>                                       <BR>       Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf &amp; "请输入编号数字(上一编号为" &amp; Nums - 1 &amp; ")" &amp; "[" &amp; Nums &amp; "]:")<BR>       If Numbers1 = "" Then Numbers1 = Nums<BR>       If pd(PPck1, PPck2) = True Then<BR>                                       Inserpt(0) = ppt(0) + 0.5 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)<BR>       Else<BR>                                       Inserpt(0) = ppt(0) - 1.5 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)<BR>       End If<BR>                               Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)<BR>                       Nums = Numbers1 '使提示与上一编号关联<BR>                       Nums = Nums + 1<BR>GoTo RETRY<BR>End Sub


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 &lt;&gt; 0 Then<BR>                                                                                                                       Err.Clear<BR>                                                                                                                       ThisDrawing.Utility.Prompt " 没有指定零件,退出"<BR>                                                                                                                       Exit Sub<BR>                                                                       End If<BR>                               PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")<BR>                                                       If Err &lt;&gt; 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, TextHeight)<BR>                       PPck2 = Cirobj.IntersectWith(line1, acExtendNone) '求交点<BR>                       line1.EndPoint = PPck2               '剪切引线<BR>                                       <BR>                       Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf &amp; "请输入编号数字(上一编号为" &amp; Nums - 1 &amp; ")" &amp; "[" &amp; Nums &amp; "]:")<BR>                       If Numbers1 = "" Then Numbers1 = Nums<BR>                       If Len(Numbers1) = 2 Then<BR>                                       Inserpt(0) = ppt(0) - 1.4 * 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>GoTo RETRY<BR>End Sub<BR>Function pd(p1 As Variant, p2 As Variant) As Boolean '判断斜率，以便确定文字位置<BR>                       If p1(0) &gt; p2(0) And p1(0) &gt; p2(0) Then<BR>                                       pd = True<BR>                       Else<BR>                                       pd = False<BR>                       End If<BR>End Function<BR>

puzb2023 发表于 2024-4-12 15:19:23

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

Klein 发表于 2024-4-12 16:09:48

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

雪山飞狐_lzh 发表于 2004-5-11 19:07:00

PPck2 = ThisDrawing.Utility.GetPoint(, "请指定编号位置：")这里改成PPck2 = ThisDrawing.Utility.GetPoint(PPck1, "请指定编号位置：")要好些吧

mikewolf2k 发表于 2004-5-11 19:23:00

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

ljcgq 发表于 2004-5-11 21:34:00

楼上说的有道理，支持

mccad 发表于 2004-5-11 21:41:00

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

gzy 发表于 2004-5-11 21:48:00

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

gzy 发表于 2004-5-12 12:52:00

加了一点对文字定位的内容，群组了编号内容。'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)]: ")
      
       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 发表于 2004-5-18 23:53:00

不错，挺实用的！

2002-ytf 发表于 2004-5-21 15:11:00

我用的编号:



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





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

woshiyu121 发表于 2004-6-3 15:59:00

我觉得你的发明很好，我画图时用的上，但是我是一个菜鸟，能否将你的发明发一个给我，并告诉我，最笨的安装方法！谢谢了！我的E ：woshiyu1217@126.com
页: [1] 2 3 4
查看完整版本: [分享]闲来无事，写了这个编号的程序