图形的自动编号 ZT

上午看了一个自动编号的帖子，所以下去我又用VBA做了一个。加了带圈的功能。


程序作者: gzy



以下内容为程序代码:<BR>'by gzy<BR><A target=_blank href="mailto:'gzy@mjtd.com" target="_blank" >'gzy@mjtd.com</A><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 &amp; "编号是否带圈[否(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





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

看来是高手来了，呵呵

这个不是LSP，不是用命令搞的。按ALT+F11，粘贴以上代码。运行即可

呵，是你的原话啊，为了给我们菜鸟提醒，所以COPY过来，懒的弄了，也没改啊

<DIV class=quote><B>以下是引用<I>gzymjtd在2004-5-12 21:36:47</I>的发言：</B><BR>在ACAD中。粘贴到thisdrawing中或一个模块中。





</DIV><BR>能说的详细一点吗?