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

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

AutoCAD Electrical 电气线路设计视频教程
AutoCAD Electrical 电气线路设计视频教程 ACE教程链接:https://pan.baidu.com/s/1TXGR94PP73O6F3iqO8xofg 提取码:honv
XP 的OFFICE 2007报宏错误，原来是简化ghost版系统少装了VBA
office2007word出现严重宏错误每次打开word就会弹出一个"宏错误窗口",要连续关六次才关的掉,去信任中心关了也没用,重装两次也没用.现在截一点弹出窗口提示的话以供参 ...
Autocad VBA初级教程
转载自CAD世界论坛普天同庆老师的作品.深表感谢!! Autocad VBA初级教程(第一课:入门) 1.为什么要写这个教程市面上ACAD VBA的书不多,它的帮助是英文版的,很多人看不懂.其实我转 ...
AutoCAD VBA 离散高程点应用
江苏省地质测绘院姜法明离散高程点应用很广,本文介绍AutoCAD VBA进行二资开发,利用离散高程点创建TIN三角形,进而绘制等高线.高程网格.地表曲面图的方法. 1.创建TIN三角形 1.1第 ...
《AutoCAD 2016中文版室内装潢设计从入门到精通》——第2章　AutoCAD 2016入门2.1　操作界面...
本节书摘来自异步社区<AutoCAD 2016中文版室内装潢设计从入门到精通>一书中的第2章,第2.1节,作者: 贾燕更多章节内容可以访问云栖社区"异步社区"公众号查 ...
Excel中的VBA宏：每次划款前从总名册中同步用户数据到当前页
2019独角兽企业重金招聘Python工程师标准>>> 我使用的Office为 Microsoft Office Professional Plus 2010,我使用的Excel 版 ...
c调用python gensim包_Jupyter Notebooks嵌入Excel并使用Python替代VBA宏
以前,Excel和Python Jupyter Notebook之间我们只能选择一个.但是现在随着PyXLL-Jupyter软件包的推出,可以将两者一起使用. 在本文中,我将向你展示如何设置在Exce ...
python 调用vba 参数保存表格_Jupyter Notebooks嵌入Excel并使用Python替代VBA宏
以前,Excel和Python Jupyter Notebook之间我们只能选择一个. 但是现在随着PyXLL-Jupyter软件包的推出,可以将两者一起使用. 在本文中,我将向你展示如何设置在Exc ...
python可以嵌在vba中吗_Jupyter Notebooks嵌入Excel并使用Python替代VBA宏
以前,Excel和Python Jupyter Notebook之间我们只能选择一个. 但是现在随着PyXLL-Jupyter软件包的推出,可以将两者一起使用. 在本文中,我将向你展示如何设置在Exc ...
面对电磁辐射干扰，如何轻松进行电子线路设计布局？
面对电磁辐射干扰,如何轻松进行电子线路设计布局? 电磁环境包含辐射和传导能量.EMC也包含辐射和敏感度两方面.辐射是指产品不必要地产生电磁能量.为了打造一种具备电磁兼容性的环境,通常需要控制辐射.敏感 ...

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