明经上的标序号源码

haibinpro

是vba的，请问有了这个源码后怎么用，保存为和格式，如何加载。和lsp的加载一样么。

'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

llmin

不会用，有会的说说。

wjh570

有高手来指导一下，谢谢！