[原创]图形的自动编号

忙了一下午，写了这个程序，感觉还很爽，故拿来分享。
程序作用：对图形指定的区域或零件进行编号，以便统计与识别。
程序思路：不用我说，看了就知道，很简单的。配合注释应该很容易理解。
声明：可供个人使用，但不得转载（毕业设计中），过了就无所谓了，呵呵！：）
程序效果如图：
<img>http://www.mjtd.com/bbs/UploadFile/2004-5/2004511181134600.gif</img>
<code>
by gzy
2004/5/11
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 = PPck

命令是什么呢？

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

呵呵，很实用啊，确实不错。
再谈谈我对cir（）这一段代码的一点想法，同gzymjtd一同探讨：
这段程序有几个细节问题：
1。一张图纸比例是不同的，如果文字只取dimtxt变量值的话有时候可能字体会偏大或偏小，我的作图习惯是一般按实际比例绘图，而且画的都是大家伙，因此仅用dimtxt值字体是偏小的。
解决办法：添加如下代码，当然还有其他方法，可以根据自己习惯设置
  textheight = ThisDrawing.GetVariable("dimtxt") 沿用系统文字高度
  tscale = ThisDrawing.GetVariable("dimscale")
  textheight = textheight * tscale
2。num初始值的定义：上一编号为－1，开始值为0，这让人觉得不舒服，呵呵
解决办法：
    Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "请输入编号数字(上一编号为" & Nums & ")" & "<" & Nums + 1 & ">:")
    If Numbers1 = "" Then Numbers1 = Nums + 1
……
Nums = Numbers1 - 1 使提示与上一编号关联
    Nums = Nums + 1（好像有点重复，不过时间仓卒（要吃饭啦：）），随便改下就传上来了）
3。这段代码只能处理1～2位的编号，能不能进一步简化代码并将编号位数扩充为3位呢？
解决办法：请看本段程序的完整代码：
Sub Cir()
RETRY:
    Dim PPck1 As Variant, PPck2 As Variant
    Dim textobject As AcadText: Dim line1 As AcadLine: Dim Cirobj As AcadCircle
    Dim ppt(0 To 2) As Double:  Dim Numbers1 As String: Dim Insectpt As Variant
    Dim tscale As Integer
   
   
     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") 沿用系统文字高度
  tscale = ThisDrawing.GetVariable("dimscale")
  textheight = textheight * tscale
  Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck2, textheight + 0.5 * tscale)
    Insectpt = Cirobj.IntersectWith(line1, acExtendNone) 求交点
    line1.EndPoint = Insectpt   剪切引线
      
    Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "请输入编号数字(上一编号为" & Nums & ")" & "<" & Nums + 1 & ">:")
    If Numbers1 = "" Then Numbers1 = Nums + 1
        Set textobject = ThisDrawing.ModelSpace.AddText(Numbers1, PPck2, textheight)
        textobject.HorizontalAlignment = acHorizontalAlignmentMiddle
    textobject.TextAlignmentPoint = PPck2
    Nums = Numbers1 - 1 使提示与上一编号关联
    Nums = Nums + 1
GoTo RETRY
End Sub
gzymjtd写的这段代码我得到的最大收获就是如何在代码中设置持续运行宏，但如果间歇运行的话恐怕还得按老办法：vbarun，这确实不如lisp方便，只要加载后敲命令就可以了，请斑竹帮忙解决下。吃饭咯～～


<em16>

多谢你的宝贵意见！
谈谈我的认为吧：
1.这个我倒想过，由于个人作图习惯不同，所以我没有采用，主要是如果比例大于1的话那个圈就太大了，我觉得不爽。由于一般人都没有设比例，所以我就沿用了系统字体高度。应该象你那样会好些！
2.这个连我自己都没有发现，呵呵！多谢！
  我又试了一下，好象没有发现“上一编号为-1”，显示的是“上一编号为0”（见图）
    Nums = Numbers1 使提示与上一编号关联
    Nums = Nums + 1
这里没有重复，Nums = Numbers1 是为了沿用人为输入的上一编号。
Nums = Nums + 1是累加，是为了使系统自动提示下一编号=上一编号的+1。

3.这个我曾试过，由于要保持1位和3位的圈是一样大，这样1位的数字在圈里就显得太小，很空荡，不爽！另外考虑到一般图纸都只涉及到两位数（我见过的，不要说我孤陋寡闻，呵呵！），所以我只搞了两位
4.由于我考虑到编号可以从任何数字开始，所以我认为没有象LSP做成命令的必要。
   如果间歇执行也可以，做成命令也行，代码如下(放入thisdrawing里面，大致如下，你去整理一下)
<code> Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
ThisDrawing.SendCommand "(defun c:gzy()(vl-vbarun ""Numbers"")(princ))(princ)" & vbCr</code>

  再次感谢你的宝贵意见！谢谢！<IMG>upload/forum/2004051315152822.gif</IMG>



<ALIGN=right><COLOR=#000066><本贴已被 作者 于 2004年05月13日 15时55分33秒 编辑过></COLOR></ALIGN>

另外还可以在输入数字后的代码加上以下代码以退出：
If Err <> 0 Then
                Err.Clear
                line1.Delete: line2.Delete 如果带圈则用cirobj.delete
                ThisDrawing.Utility.Prompt " 没有输入数字,退出"
                Exit Sub
          End If
这样就防止没有输入时而使用了默认输入。

r14能用吗？

R14应该不行。因为R14的VBA很原始，可能很多方法和属性都不支持。

不错的想法<em4>

厉害！可是我的计算机水平有限！是不是可以直接用？

怎么用呀？

如果比经CAXA好用就好了！

呵呵，很实用啊，确实不错。
再谈谈我对cir（）这一段代码的一点想法，同gzymjtd一同探讨：CAD应用及其二次开发

谢谢,顶啊!!!!

感觉很好，但不知是否实用

我还是一头雾水，楼主能否讲得明白一些？
因为我是菜鸟一只，不好意思。

good