AutoCad vba宏 用于线路设计方面简化工作量 明白的拿走

'2012.8.17
'优化改进了跨界符号插入方法
'修订版本 beat5
'增加自动括号修正
'增加编辑工作量表功能
'优化多行文本炸开统计文字(原来单行获取变为多行获取)
'增加插入块功能
'增加自动打断功能（仅限水平垂直面上）的井
'增加文本自动对齐功能
'增家位置对换功能
'增加井号自动加减
'2012.8.21
'修改优化居中对齐功能 由之前的笨算法更改为快速算法
'2012.8.22
'修改AUTOBH算法 添加井号编排
'2012.10.12
'增加按钮工具条
'===================================================================================Created By ★臭要饭的★ ===========================================================================================
'===================================================================================    制作于2012.10月  ===========================================================================================
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Var() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Dim obj As Object, bz As Boolean
Dim PointBLK() As Variant, PointZS() As Variant, HD() As ACAD_ANGLE
Dim index As Long
Dim myset As AcadSelectionSet, s As AcadMText
Dim ConRef As Object
Dim Returnd As Integer, pos As Integer, NHS As Variant, sn As Long, djs As Long, js As Long
Dim CanCalc As Boolean, CunChu As String
Dim FilterType() As Integer
Dim FilterData() As Variant
Dim i As Integer, ret As Integer
Dim sScaleFactor As Integer
Public FormActiveStatus As Boolean
Dim xlsApp As Object, xlsWorkBook As Object, xlsWorkSheet As Object
Dim Exist_ReMoved As Boolean
Public Function TXBL()
On Error GoTo ers:
Dim TextObject As Object, count As Integer
count = 1
For Each TextObject In ThisDrawing.ModelSpace
If TextObject.EntityName = "AcDbText" Then
 If InStr(TextObject.TextString, "B1") Then
sScaleFactor = Switch(TextObject.Height >= 2.5, TextObject.Height / 2.5, TextObject.Height < 2.5, 1)
Exit For
End If
ElseIf count = ThisDrawing.ModelSpace.count Then
sScaleFactor = 1
Exit For
End If
count = count + 1
Next
Exit Function
ers:
sScaleFactor = 1
End Function
Public Sub add_Menu()
Call Update_Menu(1)
Exist_ReMoved = True
End Sub
Public Sub Remove_Menu()
Call Update_Menu(0)
Exist_ReMoved = False
End Sub
Public Function Update_Menu(ByVal KG As Integer)
On Error Resume Next
With ThisDrawing
Dim HongName As Variant, HongGN As Variant, HongKey As Variant, ix As Integer
ix = 0
HongGN = Array("QTBL", "SDBL", "ZDBH", "KJFH", "BZQH", "KSBJ", "InsertBlock", "CDMBT", "AutoBH", "DDTK", "BrkPL", "ZDSS")
HongName = Array("全图统计数据", "部分统计数据", "编号与对齐工具", "插入跨接符号", "电信网通标志切换", "工作量表工具", "交点速插图块", "成端面板序号快速填充", "图元自动编号(适用于块引用)", "井管线自动打断", "多义线断开", "自动标数")
HongKey = Array(Chr(Asc("&")) + "Q", Chr(Asc("&")) + "S", Chr(Asc("&")) + "Z", Chr(Asc("&")) + "H", Chr(Asc("&")) + "B", Chr(Asc("&")) + "K", Chr(Asc("&")) + "I", Chr(Asc("&")) + "C", Chr(Asc("&")) + "A", Chr(Asc("&")) + "D", Chr(Asc("&")) + "Br", Chr(Asc("&")) + "Zs")
Dim currMenuGroup As AcadMenuGroup
Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)
Dim Mns As Object, MenuGroup As Object, Toolbar As Object
If KG = 1 Then
' 建立一个新菜单
Dim newMenu As AcadPopupMenu
Set newMenu = currMenuGroup.Menus.Add("拓展功能(" & Chr(Asc("&")) + "S)")
If newMenu Is Nothing Then
 For Each newMenu In currMenuGroup.Menus
  If newMenu.Name = "拓展功能(&S)" Then
  err.Clear
  newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.count + 1)
  Exit For
  End If
 Next
End If
' 增加子菜单
Dim FileSubMenu As AcadPopupMenu
Dim SepaMenuItem As Object    '分隔符
Set FileSubMenu = newMenu.AddSubMenu("", "光缆绘图工具")
' 在子菜单中增加一个菜单项
Dim newMenuItem As AcadPopupMenuItem
 ' 创建新工具栏
Dim newToolbar As AcadToolbar
Set newToolbar = currMenuGroup.Toolbars.Add("拓展工具")
If newToolbar Is Nothing Then
 For Each MenuGroup In .Application.MenuGroups
  With MenuGroup
    For Each Toolbar In .Toolbars
     If Toolbar.Name = "拓展工具" Then
     Toolbar.Visible = True
     Exit For
     End If
    Next
  End With
 Next
End If
newToolbar.Dock acToolbarDockLeft
' 向新工具栏添加按钮
Dim newButton As AcadToolbarItem
' 指定宏为VBA表达式
Dim FlowMacro As String, SmallBitMap As String, LargeBitmap As String
begin1:
FlowMacro = Chr(3) & Chr(3) & "(vl-vbarun " & Chr(34) & HongGN(ix) & Chr(34) & ")" & Chr(13)
Set newMenuItem = FileSubMenu.AddMenuItem(FileSubMenu.count + 1, ix + 1 & "." & HongKey(ix) & HongName(ix), FlowMacro)
Set newButton = newToolbar.AddToolbarButton("", HongName(ix), HongName(ix), FlowMacro)
SmallBitMap = Me.Path & "\icons\small\" & ix + 1 & ".bmp"
LargeBitmap = Me.Path & "\icons\big\" & ix + 1 & ".bmp"
newButton.SetBitmaps SmallBitMap, LargeBitmap
ix = ix + 1
If ix < 12 Then GoTo begin1
Set SepaMenuItem = newMenu.AddSeparator(newMenu.count + 1)
' 菜单条上显示菜单
newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.count + 1)
Exit Function
errhandle:
    If err.Number = -2147352567 Or -2145320928 Then
     err.Clear
     Resume
    End If
ElseIf KG = 0 Then
On Error Resume Next
For Each Mns In .Application.MenuBar
 If Mns.Name = "拓展功能(&S)" Then
  currMenuGroup.Menus.RemoveMenuFromMenuBar ("拓展功能(&S)")
 End If
Next
 For Each MenuGroup In .Application.MenuGroups
   With MenuGroup
    For Each Toolbar In .Toolbars
     If Toolbar.Name = "拓展工具" Then Toolbar.Visible = False
    Next
   End With
 Next
End If
End With
End Function
Public Function PtList(Points, ByVal HAlign As Boolean, ByVal VAlign As Boolean, priority As Integer)
   '对点集points 进行排序
   'priority = 0 表示先排X坐标，priority = 1 表示先排Y坐标
   'HAlign = True 表示X坐标从小到大，HAlign = False 表示X坐标从大到小
   'VAlign = True 表示Y坐标从小到大，VAlign = False 表示Y坐标从大到小
   
   Dim pt1, pt2 As Variant
   Dim n As Integer, i As Integer, j As Integer
   Dim a, B As Boolean
   n = priority
   If n = 0 Then
    a = HAlign
    B = VAlign
    ElseIf n = 1 Then
    a = VAlign
    B = HAlign
    End If
   '主方向排序
   For i = LBound(Points) To UBound(Points)
       For j = i To UBound(Points)
           pt1 = Points(i)
           pt2 = Points(j)
           If pt1(n) > pt2(n) Eqv a Then
               Points(i) = pt2
               Points(j) = pt1
           End If
       Next j
   Next i
   '副方向排序
   For i = LBound(Points) To UBound(Points)
       For j = i To UBound(Points)
           pt1 = Points(i)
           pt2 = Points(j)
         If pt1(n) = pt2(n) Then
           If pt1(1 - n) > pt2(1 - n) Eqv B Then
         Points(i) = pt2
         Points(j) = pt1
         End If
         End If
       Next j
   Next i
End Function
Public Function PlineBreak(PL As Variant, i As Integer, ByVal point As Variant) 'PolyLine连续顶点打断程序需要提供参数： PL实体对象即Polyline,i整形用于控制顶点,Point为Pline顶点列表
 Dim x As Long, NxtObj As Object, Command As String
 x = ThisDrawing.ModelSpace.count
      Command = "_break" & vbCr & PL.Handle & vbCr & point(2 + i) & "," & point(3 + i) & "," & 0 & " " & point(2 + i) & "," & point(3 + i) & "," & 0 & vbCr
      ThisDrawing.SendCommand Command
  If ThisDrawing.ModelSpace.count > x Then
   Set NxtObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.count - 1)
    If NxtObj.ObjectName = "AcDbPolyline" Then
     If UBound(NxtObj.Coordinates) > 3 Then
       i = i + 2
       PlineBreak NxtObj, i, point
     End If
    End If
  End If
End Function
Sub BrkPL()  '多线段顶点打断程序调用处
On Error GoTo errs:
Dim sets As AcadSelectionSet, obj As Object, i As Integer, point As Variant
i = 0
Set sets = ThisDrawing.SelectionSets.Add(Time())
sets.SelectOnScreen
For Each obj In sets
 If obj.ObjectName = "AcDbPolyline" Then
  point = obj.Coordinates
  PlineBreak obj, i, point
 End If
Next
errs:
Set obj = Nothing
Erase point
sets.Delete
End Sub
Public Sub DDTK()
With ThisDrawing.Application.ActiveDocument
On Error GoTo err:
Dim fType As Variant, fData As Variant, blkfType As Variant, blkfData As Variant
Dim ExtSel, PtMin As Variant, PtMax As Variant
Dim SubObj As Object, obj As Object
Dim point As Variant, sset As AcadSelectionSet, blkref As AcadSelectionSet, i As Integer
i = 1
BuildFilter fType, fData, -4, "<OR", 0, "Line", 0, "*Polyline", 0, "Circle", 0, "Arc", -4, "OR>"
BuildFilter blkfType, blkfData, -4, "<OR", 0, "Insert", -4, "OR>"
If .SelectionSets.count > 0 Then
For Each ExtSel In .SelectionSets
If ExtSel.Name = "Entitys" Then
ExtSel.Clear
Set sset = ExtSel
GoTo nxt
ElseIf ExtSel.Name = "BlkRef" Then
ExtSel.Clear
Set blkref = ExtSel
GoTo nxt
ElseIf i = ThisDrawing.SelectionSets.count Then
If sset Is Nothing Then
Set sset = ThisDrawing.SelectionSets.Add("Entitys")
End If
If blkref Is Nothing Then
Set blkref = ThisDrawing.SelectionSets.Add("BlkRef")
End If
Exit For
End If
nxt:
i = i + 1
Next
Else
Set sset = ThisDrawing.SelectionSets.Add("Entitys")
Set blkref = ThisDrawing.SelectionSets.Add("BlkRef")
End If
blkref.SelectOnScreen blkfType, blkfData
If blkref.count = 0 Then
err.Number = 10000
err.Description = "未发现有效对象，程序结束！"
GoTo err
Else
For Each obj In blkref
 If obj.ObjectName = "AcDbBlockReference" Then
 Select Case obj.Name
 Case "XinJianJing", "YuanYouJing"
  obj.GetBoundingBox PtMin, PtMax
  sset.Select acSelectionSetCrossing, PtMin, PtMax, fType, fData
    For Each SubObj In sset
     point = obj.IntersectWith(SubObj, acExtendBoth)
     Select Case UBound(point)
      Case -1
      Case 2
       .SendCommand "_break" & vbCr & "(list(handent " & Chr(34) & SubObj.Handle & Chr(34) & ")(list " & str(point(0)) & str(point(1)) & str(point(2)) & "))" & vbCr & point(0) & "," & point(1) & "," & point(2) & vbCr
      Case 5 '有两个交点的情况
       .SendCommand "_break" & vbCr & "(list(handent " & Chr(34) & SubObj.Handle & Chr(34) & ")(list " & str(point(0)) & str(point(1)) & str(point(2)) & "))" & vbCr
        Sleep 10
       .SendCommand point(3) & "," & point(4) & "," & point(5) & vbCr
        Sleep 10
      Case 7
       .SendCommand "_break" & vbCr & "(list(handent " & Chr(34) & SubObj.Handle & Chr(34) & ")(list " & str(point(0)) & str(point(1)) & str(point(2)) & "))" & vbCr & point(5) & "," & point(6) & "," & point(7) & vbCr
      Case Else
         'ThisDrawing.SendCommand "_break" & vbCr & "(list(handent " & Chr(34) & SubObj.Handle & Chr(34) & ")(list " & str(point(0)) & str(point(1)) & str(point(2)) & "))" & vbCr & point(3) & "," & point(4) & "," & point(5) & vbCr
     End Select
     Set SubObj = Nothing
    Next
    
    On Error Resume Next
    Dim tmp As AcadSelectionSet, TmpCount As Integer
     TmpCount = 1
    For Each tmp In .SelectionSets
     If tmp.Name = "TMP" Then
      tmp.Clear
      Exit For
     ElseIf TmpCount >= .SelectionSets.count Then
      Set tmp = .SelectionSets.Add("TMP")
      Exit For
     End If
      TmpCount = TmpCount + 1
    Next
    PtMax(0) = PtMax(0) - 0.7: PtMax(1) = PtMax(1) - 0.7: PtMin(0) = PtMin(0) + 0.7: PtMin(1) = PtMin(1) + 0.7
    tmp.Select acSelectionSetCrossing, PtMin, PtMax, fType, fData
     For Each SubObj In tmp
     SubObj.Delete
     Next
     tmp.Delete
    End Select
 sset.Clear
 End If
 Set obj = Nothing
Next
End If
err:
Select Case err.Number
Case 0
.Utility.Prompt "执行成功！"
Case 10000
.Utility.Prompt err.Description
Case Else
.Utility.Prompt ("执行失败！错误代码" & err.Number)
err.Clear
Resume
End Select
Erase blkfType: Erase blkfData: Erase fType: Erase fData
blkref.Delete: sset.Delete
End With
End Sub
Public Function BuildFilter(TypeArray, DataArray, ParamArray gCodes())
    Dim fType() As Integer, fData()
    Dim index As Long, i As Long
    
    index = LBound(gCodes) - 1
    For i = LBound(gCodes) To UBound(gCodes) Step 2
        index = index + 1
        ReDim Preserve fType(0 To index)
        ReDim Preserve fData(0 To index)
        fType(index) = CInt(gCodes(i))
        fData(index) = gCodes(i + 1)
    Next
    TypeArray = fType: DataArray = fData
End Function
Public Sub CDMBT()
With ThisDrawing
Dim a As AcadSelectionSet, P(0) As Integer, D(0) As Variant, i, j As Integer
Dim Tx As AcadText, Points() As Variant, NR() As String, pnt As Variant
P(0) = 0: D(0) = "Text"
Set a = .SelectionSets.Add(Time())
a.SelectOnScreen P, D
ReDim NR(a.count - 1)
ReDim Points(a.count - 1)
i = 0
For Each Tx In a
Points(i) = Tx.InsertionPoint
NR(i) = IIf((i + 1) Mod 12, (i + 1) Mod 12, 12)
i = i + 1
Next
'根据点的位置进行从左往右 从上往下依次排序
i = 0
PtList Points, True, False, 1
For Each Tx In a
Tx.Delete
Set Tx = .ModelSpace.AddText(NR(i), Points(i), 2.5)
Tx.Color = acMagenta: Tx.ScaleFactor = 0.8: Tx.StyleName = "粗宋"
i = i + 1
Next
   End With
End Sub
Public Sub QTBL()
On Error Resume Next
Dim MSpace As AcadModelSpace
Set MSpace = ThisDrawing.ModelSpace
Call TJSJ(MSpace, PointBLK, HD)
End Sub
Public Sub SDBL()
On Error Resume Next
With ThisDrawing
  Set obj = CreateObject("MSScriptControl.ScriptControl")
  obj.Language = "vbscript"
For Each myset In .SelectionSets
If myset.Name = "aaa" Then
 myset.Delete
 Exit For
End If
Next
bg1:
Set myset = .SelectionSets.Add("aaa")
myset.SelectOnScreen
 If myset.count = 0 Then
   Returnd = MsgBox("未选择有效数据，是否重新选择？", 32 + 4, "询问")
   If Returnd = vbYes Then GoTo bg1 Else Exit Sub
 End If
 Call TJSJ(myset, PointZS, HD)
 End With
End Sub
Public Function TJSJ(ByVal Area As Variant, Optional Pnts As Variant, Optional HD As Variant)
With ThisDrawing
Dim sum As Long, sun As Long, son As Long, blu As Long, grn As Long, yew As Long
Dim xlsWrite As Boolean
ReDim Pnts(0 To Area.count - 1, 2)
ReDim HD(Area.count - 1)
index = 0
For Each ConRef In Area
On Error Resume Next
 Select Case TypeName(ConRef)
  Case "IAcadText", "IAcadMtext"
    pos = InStr(ConRef.TextString, "户")
    bz = BiJiao(ConRef.InsertionPoint, Pnts, index, ConRef.Rotation, HD)
    If IsNumeric(ConRef.TextString) And ConRef.Color = acRed And bz = False Then
     sum = sum + Val(ConRef.TextString)
     index = index + 1
     'ConRef.color = acGreen 此处更改可以修改字体颜色
    ElseIf pos <> 0 And ConRef.Color = acByLayer And Not (bz) Then 'acByLayer
       CanCalc = GuoLv(ConRef.TextString, pos, CunChu)
       If CanCalc Then
        sn = sn + obj.Eval(CunChu)
        index = index + 1
       End If
    ElseIf Trim(ConRef.TextString) = "70x120" And bz = False Then
     djs = djs + 1
     index = index + 1
    ElseIf IsNumeric(ConRef.TextString) And ConRef.Color = acMagenta And bz = False Then
     sun = sun + Val(ConRef.TextString)
     index = index + 1
    ElseIf IsNumeric(ConRef.TextString) And ConRef.Color = acWhite And bz = False Then
     son = son + Val(ConRef.TextString)
     index = index + 1
    ElseIf IsNumeric(ConRef.TextString) And ConRef.Color = acBlue And bz = False Then
     blu = blu + Val(ConRef.TextString)
     index = index + 1
    ElseIf IsNumeric(ConRef.TextString) And ConRef.Color = acGreen And bz = False Then
     grn = grn + Val(ConRef.TextString)
     index = index + 1
    ElseIf IsNumeric(ConRef.TextString) And ConRef.Color = acYellow And bz = False Then
     yew = yew + Val(ConRef.TextString)
     index = index + 1
    End If
  Case "IAcadBlockReference"
   Select Case ConRef.Name
    Case "017", "XinJianJing", "YuanYouJing"
     js = js + 1
     index = index + 1
    End Select
 End Select
Next
On Error GoTo pause
Dim KWTF As Long, HTTF As Long, point As Variant, CadTxt As AcadText, TxTCollection(11) As String, Numbers(11) As Variant
ret = MsgBox("生成Excel表格吗?", vbYesNo, "提示")
KWTF = 0.41 * 0.91 * (sum + son) + 0.52 * 0.91 * sun + 0.52 * 1.02 * blu + djs * 8 + (js - djs) * 6
HTTF = (0.41 * 0.91 * (sum + son) + 0.52 * 0.91 * sun + 0.52 * 1.02 * blu) * 0.8 + (djs * 8 + (js - djs) * 6) * 0.3
point = .Utility.GetPoint(, "请指定量表插入点")
Numbers(0) = sn
Numbers(1) = CStr(Switch(sum < 100, "0" & sum / 100, sum >= 100, sum / 100))
Numbers(2) = CStr(Switch(grn < 100, "0" & grn / 100, grn >= 100, grn / 100))
Numbers(3) = CStr(Switch(son < 100, "0" & son / 100, son >= 100, son / 100))
Numbers(4) = CStr(Switch(blu < 100, "0" & blu / 100, blu >= 100, blu / 100))
Numbers(5) = CStr(Switch(sun < 100, "0" & sun / 100, sun >= 100, sun / 100))
Numbers(6) = CStr(Switch(yew < 100, "0" & yew / 100, yew >= 100, yew / 100))
Numbers(7) = js - djs
Numbers(8) = djs
Numbers(9) = CStr(Switch(KWTF < 100, "0" & KWTF / 100, KWTF >= 100, KWTF / 100))
Numbers(10) = CStr(Switch(HTTF < 100, "0" & HTTF / 100, HTTF >= 100, HTTF / 100))
TxTCollection(0) = "总计住户数：" & Numbers(0) & "户"             '统计户数
TxTCollection(1) = "新建1孔管道：" & Numbers(1) & "百米"          '红色文字统计之和
TxTCollection(2) = "新建3孔管道：" & Numbers(2) & "百米"          '绿色文字统计之和
TxTCollection(3) = "新建1孔φ50入户管道：" & Numbers(3) & "百米"  '白色文字统计之和
TxTCollection(4) = "新建4孔管道：" & Numbers(4) & "百米"          '蓝色文字统计之和
TxTCollection(5) = "新建2孔管道：" & Numbers(5) & "百米"          '粉色文字统计之和
TxTCollection(6) = "新建6孔管道：" & Numbers(6) & "百米"          '黄色文字统计之和
TxTCollection(7) = "新建70x80手孔：" & Numbers(7) & "个"          '70x80#数量
TxTCollection(8) = "新建70x120手孔：" & Numbers(8) & "个"         '70x120#数量
TxTCollection(9) = "开挖土方：" & Numbers(9) & "百立米"           '开挖土方量
TxTCollection(10) = "回填土方：" & Numbers(10) & "百立米"         '回填土方量
If ret = vbYes Then
xlsWrite = Library_Refer(ThisDrawing.Application.VBE.ActiveVBProject.References)
Call Cad2Excel(TxTCollection, xlsWrite)
End If
For i = 0 To 10
 If Numbers(i) = 0 Then GoTo nexts:
  Set CadTxt = .ModelSpace.AddText(TxTCollection(i), point, 4#)
  CadTxt.StyleName = "粗宋"
  point(1) = point(1) - 5
  Set CadTxt = Nothing
nexts:
Next i
pause:
Select Case err.Number
 Case Is = 94
  err.Clear
  Resume
 Case Else
  Erase point: Erase Numbers: Erase Pnts: Erase HD
  yew = 0: grn = 0: blu = 0: son = 0: sum = 0: sun = 0: djs = 0: js = 0: sn = 0: KWTF = 0: HTTF = 0: Set Area = Nothing
 End Select
End With
End Function
Public Sub ZDBH()
     On Error GoTo errhandle1
     ReDim FilterType(0), FilterData(0)
     With ThisDrawing
     Dim OldLineType As AcadLineType, OldTextStyle As AcadTextStyle
     Set OldLineType = .ActiveLinetype: Set OldTextStyle = .ActiveTextStyle
     FilterType(0) = 0: FilterData(0) = "Text"
     '加载默认线型
     Dim elements As AcadLineType, exists As Integer
     For Each elements In .Linetypes
      If elements.Name = "DASHED" Then
      exists = 1
      Exit For
      End If
     Next
      If exists <> 1 Then
     .Linetypes.Load "DASHED", "acad.lin"
      Set elements = .Linetypes.Item(.Linetypes.count - 1)
      End If
      .ActiveLinetype = elements
      exists = 0
     '加载默认字体
     Dim FontStyle As AcadTextStyle
     For Each FontStyle In .TextStyles
      If FontStyle.Name = "粗宋" Then
      exists = 1
      Exit For
      End If
     Next
     If exists <> 1 Then
     Set FontStyle = .TextStyles.Add("粗宋")
     FontStyle.SetFont "宋体", True, False, 1, 1
     End If
     .ActiveTextStyle = FontStyle
     Dim sKG As Integer, RK As String, YP As AcadEntity
     Dim jCount As Integer, pTxT As Variant, bh As AcadText
     Dim Jing As AcadLine, ChaRuDian As Variant
     Dim StartPoint(0 To 2) As Double, EndPoint(0 To 2)  As Double
     sKG = InputBox("1.自动井编号插入" & vbCr & "2.插入光缆编号" & vbCr & "3.自动插入井和编号" & vbCr & "4.批量移动文本" & vbCr & "5.随机标示杆距" & vbCr & "6.文本自动对齐" & vbCr & "7.井号加减工具", "询问")
     If sKG = 1 Then
      jCount = 1
      .Utility.GetEntity YP, ChaRuDian, "请选择需要标记的图元以供采样处理~！"
      If TypeName(YP) = "IAcadBlockReference" Then
      Select Case YP.Name
       Case "Ysng", "Xsng"
       RK = "P"
       Case "YuanYouJing", "XinJianJing"
       RK = "#"
       Case Else
       GoTo another:
      End Select
      Else
another:
      .Utility.Prompt "请输入所要标记的对象选项！"
       RK = .Utility.GetString(1, "1.井(#)/2.杆(P)")
      End If
      err.Clear
      Do While err.Number <> -2147352567
      pTxT = .Utility.GetPoint(, "选择插入点")
      If RK = "#" Then
      Set bh = .ModelSpace.AddText(CStr(jCount) & RK, pTxT, 2.5)
      ElseIf RK = "P" Then
      Set bh = .ModelSpace.AddText(RK & CStr(jCount), pTxT, 2.5)
      Else
      .Utility.Prompt "选项输入错误，程序终止"
      GoTo errhandle1
      End If
      jCount = jCount + 1
      bh.StyleName = "粗宋": bh.Color = acMagenta: bh.ScaleFactor = 0.8
      Loop
     ElseIf sKG = 2 Then
     Dim n As Integer, Tx As String, T As AcadText, xs As Integer, i As Integer
     Tx = InputBox("请输入光缆编号，比如“P1”", "提示")
     xs = MsgBox("更改默认入户芯数？[本数据默认以8芯入户]", vbYesNo, "询问")
     If xs = vbYes Then xs = InputBox("请输入入户光缆芯数：", "提示") Else xs = 8
     n = Val(InputBox("请输入占用芯数，例如：48", "提示")) \ xs
     Dim pnt() As ACAD_POINT
     ReDim pnt(n)
     For i = 1 To n
      pnt(i) = .Utility.GetPoint(, "请选择点")
      Set T = .ModelSpace.AddText(Tx & " " & CStr((i - 1) * xs + 1) & "-" & CStr(i * xs), pnt(i), 2.5)
      T.Color = acMagenta
     Next i
    Set T = Nothing
    ElseIf sKG = 3 Then
    jCount = 1
     Do
      ChaRuDian = .Utility.GetPoint(, "请选择基点")
      StartPoint(0) = ChaRuDian(0) - 4: StartPoint(1) = ChaRuDian(1): StartPoint(2) = ChaRuDian(2)
      EndPoint(0) = ChaRuDian(0) + 4: EndPoint(1) = ChaRuDian(1): EndPoint(2) = ChaRuDian(2)
      Set Jing = .ModelSpace.AddLine(StartPoint, EndPoint)
      Jing.Rotate ChaRuDian, 60 / 180 * 3.1415926
      Jing.Linetype = "DASHED"
      Jing.LinetypeScale = 4
      pTxT = Jing.EndPoint
      If err.Number = 0 Then
      Set bh = .ModelSpace.AddText(CStr(jCount) & "#", pTxT, 2.5)
      jCount = jCount + 1
      bh.StyleName = "粗宋": bh.Color = acMagenta: bh.ScaleFactor = 0.8
      End If
     Loop While err.Number = 0
    ElseIf sKG = 4 Then
     Dim PtStart As Variant, PtEnds As Variant
     Dim obj As Object
     i = 0
     If ThisDrawing.SelectionSets.count = 0 Then
     Set myset = .SelectionSets.Add("Move")
     Else
     For Each obj In .SelectionSets
     i = i + 1
     If obj.Name = "Move" Then
     obj.Clear
     Set myset = obj
     Exit For
     ElseIf i >= .SelectionSets.count Then
     Set myset = .SelectionSets.Add("Move")
     Exit For
     End If
     Next
     End If
     myset.SelectOnScreen FilterType, FilterData
     If myset.count = 0 Then
     .Utility.Prompt "无对象选择，退出程序"
     Exit Sub
     End If
     PtStart = .Utility.GetPoint(, "选择起始基点")
     PtEnds = .Utility.GetPoint(, "选择结束基点")
     For Each obj In myset
     obj.Move PtStart, PtEnds
     Next
    MsgBox "移动完毕~ 谢谢您的使用！"
    ElseIf sKG = 5 Then
    Dim Dis As Long, GS As Long, Lens As Integer
    Dis = CLng(.Utility.GetString(1, "请输入距离"))
    GS = CLng(.Utility.GetString(1, "请输入杆数"))
    Randomize
    Do
      pTxT = .Utility.GetPoint(, "选择插入点")
      Lens = Dis \ GS + Int(Rnd * 10)
      Set bh = .ModelSpace.AddText(Lens, pTxT, 2.5)
      bh.StyleName = "粗宋": bh.Color = acGreen: bh.ScaleFactor = 0.8
      Dis = Dis - Lens: GS = GS - 1
    Loop Until err.Number <> 0
    ElseIf sKG = 6 Then
    On Error Resume Next
    Dim point As Variant, Objects As AcadSelectionSet
    Set Objects = .SelectionSets.Add(Rnd)
    Objects.SelectOnScreen
    point = .Utility.GetPoint(, "选择基点")
    For Each obj In Objects
     obj.Move obj.InsertionPoint, point
     point(1) = point(1) - (obj.Height + (obj.Height - Int(obj.Height)))
    Next
    Set obj = Nothing: Erase point
    Objects.Delete
    ElseIf sKG = 7 Then
    Call THJH
    Else
    MsgBox "输入选项错误，退出"
    End If
errhandle1:
Select Case err.Number
 Case -2147352567
 err.Clear
 .Utility.Prompt "请选择图元继续，否则请按ESC退出"
 Resume another:
 Case Else
    err.Clear
    Erase FilterType
    Erase FilterData
    Set elements = Nothing
    Set FontStyle = Nothing
    Set Jing = Nothing
    Set bh = Nothing
    Set myset = Nothing
    .ActiveLinetype = OldLineType
    .ActiveTextStyle = OldTextStyle
End Select
    End With
End Sub
Public Sub AddEntToSSet(ByVal ent As AcadEntity, ByVal sset As AcadSelectionSet)   '添加实体到选择集
Dim objCollection(0) As AcadEntity
Set objCollection(0) = ent
sset.AddItems objCollection
End Sub
Public Sub DelEntFromSSet(ByVal ent As AcadEntity, ByVal sset As AcadSelectionSet)   '从选择集删除实体
Dim objCollection(0) As AcadEntity
Set objCollection(0) = ent
sset.RemoveItems objCollection
End Sub
Public Sub KJFH()
On Error GoTo errs
     Dim i As Integer, iCount As Long, jCount As Long
     With ThisDrawing
     Dim PolyLinexPoint As Variant, PoL As AcadLWPolyline, sets As Object, NewObj(0) As AcadEntity
     Dim Pnts(0 To 3) As Double
     Dim sset1 As Object, sset2 As Object
     Dim cir As AcadCircle, Lengths As Double
jc:
     For Each sets In .SelectionSets
      Set sets = .SelectionSets.Item(i)
      If sets.Name = "BKJ" Or sets.Name = "KJ" Then
      sets.Delete
      GoTo jc:
      End If
     Next
      Set sset1 = .SelectionSets.Add("KJ")
      Set sset2 = .SelectionSets.Add("BKJ")
      ReDim FilterType(0 To 3): ReDim FilterData(0 To 3)
       FilterType(0) = -4: FilterType(1) = 0: FilterType(2) = 0: FilterType(3) = -4
       FilterData(0) = "<OR": FilterData(1) = "*Polyline": FilterData(2) = "Line": FilterData(3) = "OR>"
       sset1.SelectOnScreen FilterType, FilterData
       sset2.SelectOnScreen FilterType, FilterData
       For iCount = 0 To sset1.count - 1
        jCount = 0
         Select Case TypeName(sset2.Item(jCount))
         Case "IAcadLine"
         Lengths = 1
         Case "IAcadLWPolyline", "IAcadPolyline"
         Lengths = sset2.Item(jCount).ConstantWidth
         End Select
        Do
         PolyLinexPoint = sset1.Item(iCount).IntersectWith(sset2.Item(jCount), acExtendNone)
         If UBound(PolyLinexPoint) = -1 Then GoTo xig
         Set cir = .ModelSpace.AddCircle(PolyLinexPoint, Lengths)
         PolyLinexPoint = cir.IntersectWith(sset2.Item(jCount), acExtendNone)
         cir.Delete
         WCS2UCS PolyLinexPoint, Pnts
         i = .ModelSpace.count
         .SendCommand "break" & vbCr & "(handent " & Chr(34) & sset2.Item(jCount).Handle & Chr(34) & ")" & vbCr & PolyLinexPoint(0) & "," & PolyLinexPoint(1) & "," & PolyLinexPoint(2) & " " & PolyLinexPoint(3) & "," & PolyLinexPoint(4) & "," & PolyLinexPoint(5) & vbCr
         If i < .ModelSpace.count Then
          Set NewObj(0) = .ModelSpace.Item(i - 2)
          sset2.AddItems NewObj
         End If
         Set PoL = .ModelSpace.AddLightWeightPolyline(Pnts)
         PoL.SetWidth 0, Lengths, Lengths
         PoL.SetBulge 0, 1
         PoL.Color = acGreen
         PoL.Update
xig:
        jCount = jCount + 1
        Loop Until jCount = sset2.count
       Next iCount
errs:
       On Error Resume Next
       err.Clear
       sset1.Delete
       sset2.Delete
       Set sset1 = Nothing
       Set sset2 = Nothing
       End With
End Sub
Public Sub BZQH()
With ThisDrawing
Dim xxx As Integer, LFT As ACAD_POINT, RIT As ACAD_POINT
Dim Pivot(0 To 2) As Double
xxx = InputBox("电信标志转换网通标志请输入0" & vbCr & "网通标志转换电信标志请输入1", "提示")
bg2:
For Each myset In .SelectionSets
If myset.Name = "aaa" Then
myset.Delete
Exit For
End If
Next
Set myset = .SelectionSets.Add("aaa")
myset.SelectOnScreen
 If myset.count = 0 Then
   Returnd = MsgBox("未选择有效数据，是否重新选择？", 32 + 4, "询问")
   If Returnd = vbYes Then GoTo bg2 Else Exit Sub
 End If
ReDim PointZS(0 To myset.count - 1, 2)
ReDim HD(myset.count)
For Each ConRef In myset
  Select Case TypeName(ConRef)
   Case "IAcadText"
    bz = BiJiao(ConRef.InsertionPoint, PointZS, index, ConRef.Rotation, HD)
     If Not (bz) Then
      ConRef.TextString = TEL2CNC(ConRef.TextString, xxx)
       If ConRef.Rotation > 1.5707963267949 Then
        ConRef.GetBoundingBox LFT, RIT
        Pivot(0) = LFT(0) + (RIT(0) - LFT(0)) / 2
        Pivot(1) = LFT(1) + (RIT(1) - LFT(1)) / 2
        Pivot(2) = (LFT(2) + RIT(2)) / 2
        ConRef.Rotate Pivot, 180 / 180 * 3.1415926
       End If
      index = index + 1
     End If
   Case "IAcadBlockReference"
  End Select
Next
.Utility.Prompt "已经修改完毕，请查看效果."
Set myset = Nothing
End With
End Sub
Public Sub KSBJ()
begin:
With ThisDrawing
     ReDim FilterType(0) As Integer, FilterData(0) As Variant
     Dim KGG As Integer
     KGG = InputBox("0.编辑工作量表" & "1.快速删除文本", "提示")
      If KGG = 0 Then
      For Each myset In .SelectionSets
       If myset.Name = "aaa" Then
       .SelectionSets.Item("aaa").Delete
       Exit For
       End If
      Next
      Set myset = .SelectionSets.Add("aaa")
      Dim str As String, pot As ACAD_POINT, insertPoints(0 To 2) As Double, TxT As AcadText, _
      tmp As String, indx As Integer, Ftsize As Double, SStr As String, TableHeight As Double, _
      DwPoint(0 To 2) As Double, ShuPoint(0 To 2) As Double, dw As String, CenterPoint(0 To 2) As Variant, BoderPoint(0 To 2) As Variant, KuanDu As Double
      Dim AlignPoint(0 To 2) As Double
      FilterType(0) = 0: FilterData(0) = "Text"
      myset.SelectOnScreen FilterType, FilterData
      If myset.count <> 0 Then
      Ftsize = 4
      Else
      Ftsize = InputBox("未选择字体大小，请输入字号大小：", "提示")
      End If
      For Each ConRef In myset
      ConRef.Delete
      Next
      pot = .Utility.GetPoint(, "请指定基点")
      str = InputBox("输入文本")
      insertPoints(0) = pot(0) + 1: insertPoints(1) = pot(1) - 6: insertPoints(2) = 0
      MoveToCenter insertPoints, AlignPoint, 0, TableHeight
      For indx = 1 To Len(str)
       tmp = Mid(str, indx, 1)
        If Asc(tmp) < 0 Then
         Set TxT = .ModelSpace.AddText(tmp, insertPoints, Ftsize)
         TxT.StyleName = "粗宋": TxT.Color = acByLayer: TxT.ScaleFactor = 0.8
         TxT.HorizontalAlignment = acHorizontalAlignmentMiddle
         TxT.TextAlignmentPoint = AlignPoint
         Set TxT = Nothing
        ElseIf Asc(tmp) > 0 And tmp <> "(" And tmp <> ")" Then
         Do
         SStr = SStr & tmp
         indx = indx + 1
         If indx > Len(str) Then Exit Do Else tmp = Mid(str, indx, 1)
         Loop Until Asc(tmp) < 0
         Set TxT = .ModelSpace.AddText(SStr, insertPoints, Ftsize)
         TxT.StyleName = "粗宋": TxT.Color = acByLayer
          If Len(SStr) <= 2 Then
          TxT.ScaleFactor = 0.8
          ElseIf Len(SStr) <= 4 Then
          TxT.ScaleFactor = 0.75
          Else
          TxT.ScaleFactor = 0.6
          End If
         TxT.HorizontalAlignment = acHorizontalAlignmentMiddle
         TxT.TextAlignmentPoint = AlignPoint
         Set TxT = Nothing
         SStr = ""
         indx = indx - 1
        ElseIf tmp = "(" Or tmp = ")" Then
         Set TxT = .ModelSpace.AddText(tmp, insertPoints, Ftsize)
         TxT.StyleName = "粗宋": TxT.Color = acByLayer: TxT.ScaleFactor = 0.8
         TxT.HorizontalAlignment = acHorizontalAlignmentMiddle
         TxT.TextAlignmentPoint = AlignPoint
         TxT.Rotate AlignPoint, -3.1415926 / 2
         Set TxT = Nothing
        End If
        insertPoints(1) = insertPoints(1) - Ftsize - 2
        AlignPoint(1) = AlignPoint(1) - Ftsize - 2
      Next indx
      Erase AlignPoint
      Erase insertPoints
      dw = calcDW(str) '选择单位 并填写
      DwPoint(0) = pot(0) + 1: ShuPoint(0) = pot(0) + 1
      DwPoint(1) = pot(1) - TableHeight - 1: ShuPoint(1) = DwPoint(1) - 7
      DwPoint(2) = 0: ShuPoint(2) = 0
      Set TxT = .ModelSpace.AddText(dw, DwPoint, 3.5)
      MoveToCenter DwPoint, AlignPoint, 1
      TxT.HorizontalAlignment = acHorizontalAlignmentMiddle
      TxT.TextAlignmentPoint = AlignPoint
      TxT.StyleName = "粗宋": TxT.Color = acByLayer: TxT.ScaleFactor = 0.8
      Set TxT = .ModelSpace.AddText("0000", ShuPoint, 3.5)
      MoveToCenter ShuPoint, AlignPoint, 1
      TxT.HorizontalAlignment = acHorizontalAlignmentMiddle
      TxT.TextAlignmentPoint = AlignPoint
      TxT.StyleName = "粗宋": TxT.Color = acByLayer: TxT.ScaleFactor = 0.8
      ret = MsgBox("继续修改下一项么？", vbYesNo)
      Erase AlignPoint
      Erase ShuPoint
      Erase DwPoint
      If ret = vbYes Then GoTo begin:
      ElseIf KGG = 1 Then
      Dim BBC As Object
      FilterType(0) = 0: FilterData(0) = "Text"
      i = 0
       For Each BBC In .SelectionSets
        If BBC.Name = "TxT" Or i >= .SelectionSets.count Then
        BBC.Delete
        Exit For
        End If
         i = i + 1
       Next
        Set BBC = .SelectionSets.Add("TxT")
        BBC.SelectOnScreen FilterType, FilterData
         For Each obj In BBC
          obj.Delete
         Next
         Set BBC = Nothing
        .Utility.Prompt " 清理完毕,请继续工作！"
        End If
        End With
err:
        err.Clear
        Set TxT = Nothing
End Sub
Public Sub InsertBlock()
On Error GoTo err
Call TXBL
Dim ObjDBX As Object
Dim Name As String
Dim blkObj(0) As Object, Points() As Variant, HD() As Variant
Name = "E:\workspace\图例.dwg"
 If Dir(Name, vbArchive) = "" Then
 err.Number = 101
 GoTo err:
 End If
    If Left(Version, 2) = "15" Then
        Set ObjDBX = CreateObject("ObjectDBX.AxDbDocument.1")
    ElseIf Left(Version, 2) = "16" Then
        Set ObjDBX = CreateObject("ObjectDBX.AxDbDocument.16")
    ElseIf Left(Version, 2) = "17" Then
        Set ObjDBX = CreateObject("ObjectDBX.AxDbDocument.17")
    End If
With ThisDrawing
  ObjDBX.Open Name
  For Each obj In ObjDBX.Blocks
   If Left(obj.Name, 1) <> "*" Then UserForm1.ComboBox1.AddItem obj.Name
  Next
  UserForm1.ComboBox1.Text = UserForm1.ComboBox1.List(0)
Dim curObj As Object, j As Integer, ss As Object, x As Long, errs As Integer
Dim point As Variant, npoint(0 To 2) As Double
Dim Sname As String, PT As Variant
UserForm1.Show
UserForm1.ComboBox1.SetFocus
Sname = UserForm1.ComboBox1.Text
If Sname = "" Then Exit Sub
Set blkObj(0) = ObjDBX.Blocks(Sname)
ObjDBX.CopyObjects blkObj, .ModelSpace
For Each ss In .SelectionSets
 If ss.Name = "aaa" Then
  ss.Delete
  Exit For
 End If
Next
Set ss = ThisDrawing.SelectionSets.Add("aaa")
ss.SelectOnScreen
If ss.count >= 2 Then
For i = 0 To ss.count - 1
     ReDim Preserve Points(ss.count ^ 2, 0 To 2) '这里有点小问题判断1维数组的下标
     ReDim Preserve HD(ss.count ^ 2) '判断1维数组下标
j = i
 Do
   point = ss.Item(i).IntersectWith(ss.Item(j), acExtendNone)
   x = UBound(point)
    If x > 0 Then
    Do
     Splits point, x, npoint
     x = x - 3
      If Not BiJiao(npoint, Points, index, 0, HD) Then
        If IsNull(Sname) <> True Then
         Set curObj = .ModelSpace.InsertBlock(npoint, Sname, 1#, 1#, 1#, 0)
         curObj.ScaleEntity npoint, sScaleFactor
         index = index + 1
        End If
      End If
    Loop While x > 0
    End If
    Erase npoint
    Erase point
     j = j + 1
 Loop While j < ss.count
Next i
Else
.Utility.Prompt "只有一个元素，没有交点"
Set ss = Nothing
Exit Sub
End If
.Utility.Prompt "执行完毕！"
End With
err.Clear
Set ObjDBX = Nothing
Erase HD: Erase Points
UserForm1.ComboBox1.Clear
Set ss = Nothing
err:
 Select Case err.Number
  Case -2147467259
   ret = MsgBox("文件被占用或已经打开，是否关闭？", vbYesNo, "提示")
    If ret = vbYes Then Call CloseFile(Name)
  Case 101
  ret = MsgBox("错误101！文件未找到或不存在，请检查！", vbDefaultButton1, "提示")
  Case Else '-2147024809, 0
  err.Clear
  UserForm1.ComboBox1.Clear
  Set ObjDBX = Nothing
  Set ss = Nothing
  index = 0
  Erase HD: Erase Points
  End Select
End Sub
Public Function CloseFile(ByVal File As String)
Dim DC As AcadDocument
For Each DC In ThisDrawing.Application.Documents
If DC.FullName = File Then DC.Close
Set DC = Nothing
Next
End Function
Public Function Splits(point As Variant, ByVal j As Integer, RPoint As Variant)
Dim i As Integer
 For i = 0 To 2
  RPoint(2 - i) = point(j - i)
 Next i
End Function
Public Function MoveToCenter(ByVal MoveFromPoint As Variant, MoveToPoint As Variant, func As Integer, Optional tblHeight As Double)
Dim tmp As Variant, Max As Double
tmp = BorderPoint(ThisDrawing, MoveFromPoint)
 MoveToPoint(0) = (tmp(0) + tmp(3) + tmp(6) + tmp(9)) / 4
  If func = 0 Then
    If Not (tmp(1) Xor tmp(4) Xor tmp(7) Xor tmp(10)) Then
     tblHeight = Abs(tmp(1) + tmp(4) - tmp(7) - tmp(10)) / 2
    ElseIf Not (tmp(1) Xor tmp(7) Xor tmp(4) Xor tmp(10)) Then
     tblHeight = Abs(tmp(1) + tmp(7) - tmp(4) - tmp(10)) / 2
    End If
    MoveToPoint(1) = MoveFromPoint(1)
  ElseIf func = 1 Then
  MoveToPoint(1) = (tmp(1) + tmp(4) + tmp(7) + tmp(10)) / 4
 End If
MoveToPoint(2) = 0
End Function
Public Function BorderPoint(ByVal SelDoc As AcadDocument, ByVal SelPoint As Variant) As Variant
'按些定点返回边界,有边界时返回边界点集和,无边界返加0
1:
Dim i As Integer, m As Integer, n As Long
Dim lwpLineObj As Object
Dim explodedObjects As Variant
Dim explodedLine As AcadLine
Dim point() As Double
Dim Border() As Double
Dim RT As Integer
n = SelDoc.ModelSpace.count
' 调用BOUNDARY命令获取某一点处的边界
SelDoc.SendCommand "_-Boundary" & vbCr & SelPoint(0) & "," & SelPoint(1) & vbCr & vbCr
' 如果存在边界，则会生成新的实体
If SelDoc.ModelSpace.count > n Then
Set lwpLineObj = SelDoc.ModelSpace.Item(SelDoc.ModelSpace.count - 1)
Else
 RT = MsgBox("未发现有效的板材边界!重新生成吗？", vbExclamation + vbYesNo, "系统提示")
  If RT = vbYes Then GoTo 1:
  BorderPoint = 0
Exit Function
End If
'取出边界线
explodedObjects = lwpLineObj.Explode
lwpLineObj.Delete
ReDim point((UBound(explodedObjects) + 1) * 6 - 1)
ReDim Border((UBound(explodedObjects) + 1) * 3 - 1)
For n = 0 To UBound(explodedObjects)
If explodedObjects(n).ObjectName <> "AcDbLine" Then
MsgBox "当前所选取板材边界错误,请重选!", vbExclamation + vbOKOnly, "系统提示"
BorderPoint = 0
GoTo 100
End If
Set explodedLine = explodedObjects(n)
point(n * 6 + 0) = explodedLine.StartPoint(0)
point(n * 6 + 1) = explodedLine.StartPoint(1)
point(n * 6 + 2) = explodedLine.StartPoint(2)
point(n * 6 + 3) = explodedLine.EndPoint(0)
point(n * 6 + 4) = explodedLine.EndPoint(1)
point(n * 6 + 5) = explodedLine.EndPoint(2)
Next
'算出边界点
i = 0
Border(0) = point(0)
Border(1) = point(1)
Border(2) = point(2)
For n = 0 To (UBound(point) + 1) / 3 - 1
For i = 0 To m
If Border(i * 3 + 0) = point(n * 3 + 0) And Border(i * 3 + 1) = point(n * 3 + 1) And Border(i * 3 + 2) = point(n * 3 + 2) Then
Exit For
End If
Next
If i = m + 1 Then
Border(i * 3 + 0) = point(n * 3 + 0)
Border(i * 3 + 1) = point(n * 3 + 1)
Border(i * 3 + 2) = point(n * 3 + 2)
m = m + 1
End If
Next
BorderPoint = Border
'删除边界线
100:
For n = 0 To UBound(explodedObjects)
explodedObjects(n).Delete
Next
End Function
Public Function WCS2UCS(ByVal OrginPoint As Variant, Coordinas As Variant)
Dim s As Integer, i As Integer
 s = 0
 For i = 0 To UBound(OrginPoint)
  If (i + 1) Mod 3 <> 0 Then
  Coordinas(s) = OrginPoint(i)
  s = s + 1
  End If
 Next i
End Function
Public Function calcDW(ByVal str As String) As String
 If InStr(str, "测量") Or InStr(str, "墙壁钉固") Then
  calcDW = "百米"
 ElseIf InStr(str, "夯填") Or InStr(str, "土方") Then
 calcDW = "百立米"
 ElseIf InStr(str, "管道") Or InStr(str, "架空") Then
  calcDW = "千米"
 ElseIf InStr(str, "手孔抽水") Or InStr(str, "接头盒") Or InStr(str, "开窗口") Then
 calcDW = "个"
 ElseIf InStr(str, "引上") Then
 calcDW = "条"
 ElseIf InStr(str, "成端接续") Then
 calcDW = "芯"
 ElseIf InStr(str, "墙洞") Or InStr(str, "手孔") Then
 calcDW = "个"
 ElseIf InStr(str, "拉管") Then
 calcDW = "百米"
 ElseIf InStr(str, "光缆接续") Then
 calcDW = "头"
 ElseIf InStr(str, "开挖花砖") Then
 calcDW = "百平米"
 End If
End Function
Public Function TEL2CNC(NM As String, ByVal KG As Integer) As String
Dim ps As Integer
 If KG = 0 Then
  Select Case NM
   Case "GYTA-144B1", "144B1"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-144D", "144D")
   Case "GYTA-72B1", "72B1"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-72D", "72D")
   Case "GYTA-48B1", "48B1"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-48D", "48D")
   Case "GYTA-24B1", "24B1"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-24D", "24D")
   Case "GYTA-12B1", "12B1"
    TEL2CNC = IIf(Len(NM) > 4, "GYTXW-12D", "12D")
   Case "GYTA-8B1", "8B1"
    TEL2CNC = IIf(Len(NM) > 4, "GYTXW-8D", "8D")
   Case "GYTA-4B1", "4B1"
    TEL2CNC = IIf(Len(NM) > 4, "GYTXW-4D", "4D")
   Case Else
   TEL2CNC = NM
  End Select
     ps = InStr(NM, "电信")
     If ps <> 0 Then
     TEL2CNC = Replace(NM, "电信", "网通")
     NM = NM
    End If
 ElseIf KG = 1 Then
  Select Case NM
   Case "GYTA-144D", "144D"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-144B1", "144B1")
   Case "GYTA-72D", "72D"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-72B1", "72B1")
   Case "GYTA-48D", "48D"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-48B1", "48B1")
   Case "GYTA-24D", "24D"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-24B1", "24B1")
   Case "GYTXW-12D", "12D"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-12B1", "12B1")
   Case "GYTXW-8D", "8D"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-8B1", "8B1")
   Case "GYTXW-4D", "4D"
    TEL2CNC = IIf(Len(NM) > 4, "GYTA-4B1", "4B1")
   Case Else
   TEL2CNC = NM
  End Select
    If InStr(NM, "网通") <> 0 Then
     TEL2CNC = Replace(NM, "网通", "电信")
    End If
 Else
 End If
End Function
Public Function BiJiao(ByVal point As Variant, Point1 As Variant, Optional index As Long, Optional Hudu As ACAD_ANGLE, Optional HD As Variant) As Boolean
Dim AA As Double, BB As Double, cc As Double, dd As Double, ee As Double, ff As Double
Dim i As Integer
AA = point(0)
BB = point(1)
cc = point(2)
For i = 0 To index
dd = Point1(i, 0)
ee = Point1(i, 1)
ff = Point1(i, 2)
If IsMissing(Hudu) Or IsMissing(HD) Then
 If Int(AA) = Int(dd) And Int(BB) = Int(ee) And Int(cc) = Int(ff) Then '如果未传递弧度数据的话只比较三组坐标数据
  BiJiao = True
  Exit Function
 Else
  BiJiao = False
 End If
Else
If Int(AA) = Int(dd) And Int(BB) = Int(ee) And Int(cc) = Int(ff) And Hudu = HD(i) Then '过滤重复数据 位置偏移大于1为不重复
  BiJiao = True
  Exit Function
Else
  BiJiao = False
End If
End If
Next i
Point1(index, 0) = point(0)
Point1(index, 1) = point(1)
Point1(index, 2) = point(2)
HD(index) = Hudu
End Function
Public Function GuoLv(ByVal NHS As String, ByVal pos As Integer, CunChu As String) As Boolean
Dim i As Integer, xx As String, ix As String
xx = "0123456789+-*"
i = 1
NHS = Replace(Left(NHS, pos - 1), "x", "*")
Do
 ix = Mid(NHS, i, 1)
  If InStr(xx, ix) = 0 Then
    GuoLv = False
    Exit Do
   Else
    GuoLv = True
    CunChu = NHS
  End If
  i = i + 1
Loop Until i > Len(NHS)
End Function
'在自动运行宏中执行加载菜单
Sub AcadStartup()
With ThisDrawing
If Exist_ReMoved Then Call Remove_Menu Else Call add_Menu
.SetVariable "filedia", 1
End With
End Sub
Public Sub AutoBH()
On Error GoTo err:
With ThisDrawing
Dim FilterType(0) As Integer, FilterData(0) As Variant
Dim OldLineType As AcadLineType, OldTextStyle As AcadTextStyle
     Set OldLineType = .ActiveLinetype: Set OldTextStyle = .ActiveTextStyle
     FilterType(0) = 0: FilterData(0) = "Text"
     '加载默认线型
     Dim elements As AcadLineType, exists As Integer
     For Each elements In .Linetypes
      If elements.Name = "DASHED" Then
      exists = 1
      Exit For
      End If
     Next
      If exists <> 1 Then
     .Linetypes.Load "DASHED", "acad.lin"
      Set elements = .Linetypes.Item(.Linetypes.count - 1)
      End If
      .ActiveLinetype = elements
      exists = 0
     '加载默认字体
     Dim FontStyle As AcadTextStyle
     For Each FontStyle In .TextStyles
      If FontStyle.Name = "粗宋" Then
      exists = 1
      Exit For
      End If
     Next
     If exists <> 1 Then
     Set FontStyle = .TextStyles.Add("粗宋")
     FontStyle.SetFont "宋体", True, False, 1, 1
     End If
     .ActiveTextStyle = FontStyle
Dim PSafeArray As Long, i As Integer, j As Integer
Dim GanPts As New Collection, JingPts As New Collection
Dim obj As Object, TxT As Object
Dim GDian() As Variant, JDian() As Variant, point(0 To 2) As Double
Dim FtStyle As AcadTextStyle
ret = MsgBox("部分标记吗？", vbYesNo, "提示")
Dim myselects As AcadSelectionSet
Set myselects = .SelectionSets.Add(Time())
If ret = vbYes Then
myselects.SelectOnScreen
ElseIf ret = vbNo Then
myselects.Select acSelectionSetAll
Else
GoTo err
End If
For Each obj In myselects
 If TypeName(obj) = "IAcadBlockReference" Then
 Select Case obj.Name
  Case "Ysng", "Xsng", "026"
   GanPts.Add obj.InsertionPoint
   ReDim GDian(GanPts.count - 1)
   For i = LBound(GDian) To UBound(GDian)
   point(0) = GanPts(i + 1)(0) + 2.5
   point(1) = GanPts(i + 1)(1) + 2.5
   point(2) = 0
   GDian(i) = point
   Next i
  Case "YuanYouJing", "XinJianJing"
   JingPts.Add obj.InsertionPoint
   ReDim JDian(JingPts.count - 1)
   For j = LBound(JDian) To UBound(JDian)
   point(0) = JingPts(j + 1)(0) + 2.5
   point(1) = JingPts(j + 1)(1) + 2.5
   point(2) = 0
   JDian(j) = point
   Next j
 End Select
 End If
Next
CopyMemory PSafeArray, ByVal VarPtrArray(GDian), 4 '从数组的SafeArray结构头中得到实际数据的地址
If PSafeArray Then
   PtList GDian, True, False, 1
   For i = LBound(GDian) To UBound(GDian)
    Set TxT = .ModelSpace.AddText("P" & i + 1, GDian(i), 2.5)
    TxT.Color = 6: TxT.StyleName = "粗宋"
   Next i
End If
CopyMemory PSafeArray, ByVal VarPtrArray(JDian), 4 '从数组的SafeArray结构头中得到实际数据的地址
If PSafeArray Then
   PtList JDian, True, False, 1
   For i = LBound(JDian) To UBound(JDian)
    Set TxT = .ModelSpace.AddText(i + 1 & "#", JDian(i), 2.5)
    TxT.Color = 6: TxT.StyleName = "粗宋"
   Next i
End If
err:
Select Case err.Number
 Case 0
  .Utility.Prompt "执行成功"
 Case 1
 Case 9
  .Utility.Prompt err.Description & vbCr & "可能本图中未找到图元，请核实！"
End Select
err.Clear
Set TxT = Nothing: myselects.Delete
.ActiveLinetype = OldLineType
.ActiveTextStyle = OldTextStyle
End With
End Sub
Function ExplodeBlockRef(pBlockRef) As Collection
On Error Resume Next
Dim i, j
Dim pEnts, es As Variant
Dim EBR As New Collection
pEnts = pBlockRef.Explode
For i = 0 To UBound(pEnts)
If pEnts(i).ObjectName <> "AcDbBlockReference" Then
EBR.Add pEnts(i)
Else
Set es = ExplodeBlockRef(pEnts(i))
pEnts(i).Delete
For j = 1 To es.count
EBR.Add es(j)
Next j
End If
Next i
Set ExplodeBlockRef = EBR
End Function
Sub tt()
On Error Resume Next
With ThisDrawing
Dim obj As AcadEntity, pnt As Variant, Nname As String, NewObj As AcadBlock, NewCollec As New Collection
Dim i As Integer, xsc, ysc, zsc, SC As Double, Objects() As Object
ThisDrawing.Utility.GetEntity obj, pnt
xsc = obj.XScaleFactor: ysc = obj.YScaleFactor: zsc = obj.ZScaleFactor
SC = 1 / xsc
obj.ScaleEntity pnt, SC
pnt = obj.InsertionPoint
Nname = obj.Name
Set NewCollec = ExplodeBlockRef(obj)
obj.Delete
ReDim Objects(NewCollec.count - 1)
For Each obj In NewCollec
If obj.ObjectName = "AcDbAttributeDefinition" Then
obj.Delete
ReDim Preserve Objects(i - 1)
i = i + 1
Else
obj.Color = acGreen
Set Objects(i) = obj
i = i + 1
End If
Next
Set NewObj = ThisDrawing.Blocks.Add(pnt, Nname)
ThisDrawing.CopyObjects Objects, NewObj
For Each obj In NewCollec
obj.Delete
Next
Set obj = .ModelSpace.InsertBlock(pnt, Nname, xsc, ysc, zsc, 0)
End With
End Sub
Sub duidiao()
On Error Resume Next
With ThisDrawing
Dim a As Object, B As Object, pnt1, pnt2 As Variant
.Utility.GetEntity a, pnt1, "选择图元1"
.Utility.GetEntity B, pnt1, "选择图元2"
pnt1 = a.InsertionPoint: pnt2 = B.InsertionPoint
If err.Number <> 0 Then
err.Clear
pnt1 = .Utility.GetPoint(, "手动选择基点1")
pnt2 = .Utility.GetPoint(, "手动选择基点2")
End If
a.Move pnt1, pnt2: B.Move pnt2, pnt1
Set a = Nothing: Set B = Nothing
End With
End Sub
Sub THJH() '按一定间隔替换井号，比如井号为1#，2#，3#，能替换成为5#.6#.7#
On Error Resume Next
UserForm2.Show
'Dim activecolor As Long
'activecolor = UserForm2.Image1.BorderColor
If Not FormActiveStatus Then
Exit Sub
End If
Dim sets As AcadSelectionSet, xuhao As String, ins As Integer
ins = InputBox("请输入延后间隔数目,逻辑加请输入正数，逻辑减输入负数", "询问", 0)
Set sets = ThisDrawing.SelectionSets.Add(Time())
sets.SelectOnScreen
On Error GoTo errs
i = 1
For Each obj In sets
If obj.ObjectName = "AcDbText" Then
 If CStr(obj.Color) = Right(UserForm2.ComboBox1.Text, Len(obj.Color)) And InStr(obj.TextString, "#") <> 0 Then
 xuhao = Left(obj.TextString, Len(obj.TextString) - 1)
  If IsNumeric(xuhao) Then
   obj.TextString = Val(xuhao) + ins & "#"
  End If
 End If
 End If
errs:
err.Clear
Next
sets.Delete
End Sub
Sub ZDSS()
On Error GoTo errs
With ThisDrawing
Dim obj As Object, pnt1 As Variant, pnt2 As Variant, TxT As String, NewTxt As AcadText, point(0 To 2) As Double
Do While err.Number = 0
 pnt1 = .Utility.GetPoint(, "选择起始基点")
 pnt2 = .Utility.GetPoint(, "选择结束基点")
 point(0) = (pnt2(0) + pnt1(0)) / 2
 point(1) = (pnt1(1) + pnt2(1)) / 2
 point(2) = 0
 TxT = CStr(Round(Sqr((pnt1(0) - pnt2(0)) ^ 2 + (pnt1(1) - pnt2(1)) ^ 2)))
 Set NewTxt = .ModelSpace.AddText(TxT, point, 2.5)
NewTxt.StyleName = "粗宋"
Loop
errs:
err.Clear
Set NewTxt = Nothing
End With
End Sub
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
ThisDrawing.SetVariable "filedia", 1
End Sub
Public Function Cad2Excel(ByVal SZ As Variant, RetResult As Boolean)
 On Error Resume Next
 Set xlsApp = GetObject(, "Excel.Application")
 If err Then
  err.Clear
  Set xlsApp = CreateObject("Excel.Application")
  If err Then
   err.Clear
   MsgBox "未能创建Excel系列组件，请核查是否安装。"
   Exit Function
  End If
 End If
 If RetResult Then
 xlsApp.Visible = True
 With xlsApp
 Set xlsWorkBook = xlsApp.workbooks.Add("")
 Set xlsWorkSheet = xlsWorkBook.Sheets("Sheet1")
 On Error GoTo ErrTraps:
   With xlsWorkSheet
    For i = LBound(SZ) To UBound(SZ)
    .Range("A" & (i + 1)).FormulaR1C1 = SZ(i)
    Next i
    .Columns("A:A").Select
    End With
    With .Selection
        .Columns.AutoFit
        .Rows.AutoFit
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = -5002
        .MergeCells = False
   End With
   xlsWorkSheet.Range("A1").Select
   End With
   Exit Function
Else
ErrTraps:
MsgBox err.Description
err.Clear
Set xlsApp = Nothing
Set xlsWorkBook = Nothing
Set xlsWorkSheet = Nothing
'xlsApp.Save
End If
End Function
Public Function Library_Refer(RefLibrarys As Variant) As Boolean
 On Error Resume Next
 Dim RefLibrary As Variant
 For Each RefLibrary In RefLibrarys
 If RefLibrary.GUID = "{00020813-0000-0000-C000-000000000046}" Then GoTo exists
 Next
 Dim RefItem(1, 3) As Variant
    RefItem(0, 0) = "{00020813-0000-0000-C000-000000000046}"
    RefItem(0, 1) = 1
    RefItem(0, 2) = 5
    Dim errmsg As String
    ThisDrawing.Application.VBE.ActiveVBProject.References.AddFromGuid RefItem(0, 0), RefItem(0, 1), RefItem(0, 2)
exists:
Select Case err.Number
  Case Is = 32813
     '引用已经加载，无需做任何事情
     err.Clear
     Library_Refer = True
  Case Is = vbNullString
     '成功加载
     err.Clear
     Library_Refer = True
  Case Else
     '加载出现错误，保存错误信息
    errmsg = errmsg & RefItem(i, 0) & "出现错误"
     Library_Refer = False
    err.Clear
End Select
End Function