[原创]借助Excel更改零件号

兰州人

绘制施工图时，在件号1~50之间补插入17和18零件号，通常方法是人工来更改后面零件号。如图所示。

本人的解决方案是，将施工图里的件号图层的件号读到到Excel中，在Excel中1~50间的17、18后，插入19、20件号。采用ObjectToObject更改原施工图里件号，效率高，实用性强。程序如下。

2. Sub ReadPartNo()
3.   Dim xlSheet
4.   Set xlSheet = xlApp.sheets(1)
5.   Dim ss1 As AcadSelectionSet
6.   Dim layername As String
7.   Dim AcadEnt As AcadEntity
8.   'Dim pp1 As AcadPoint, pp2 As AcadPoint
9.   '指定图层名称
10.   'Set pp1 = ThisDrawing.Utility.GetPoint
11.   'Set pp2 = ThisDrawing.Utility.GetPoint
12.   layername = "件号"
13.   Dim tt As AcadText, MTt As AcadMText
14.   '得到选择集
15.   Dim gpCode(0) As Integer
16.   Dim dataValue(0) As Variant
17.   gpCode(0) = 8
18.   dataValue(0) = layername
19. '  ss1.Delete
20.   ii = 1
21.   Set ss1 = ThisDrawing.SelectionSets.Add("sss")
22.   ss1.Select acSelectionSetAll, , , gpCode, dataValue
23.   'ss1.Select acSelectionSetCrossing, pp1, pp2, , dataValue
24. For Each AcadEnt In ss1
25.   'Debug.Print AcadEnt.ObjectName
26.   Select Case AcadEnt.ObjectName
27.     Case "AcDbText"
28.       Set tt = AcadEnt
29.       With tt
30.         xlSheet.cells(ii, 1).Value = .TextString
31.         xlSheet.cells(ii, 2).Value = .InsertionPoint(0)
32.         xlSheet.cells(ii, 3).Value = .InsertionPoint(1)
33.         xlSheet.cells(ii, 4).Value = .Layer
34.         xlSheet.cells(ii, 5).Value = .ScaleFactor
35.         xlSheet.cells(ii, 6).Value = .color
36.         xlSheet.cells(ii, 7).Value = .ObjectID
37.         ii = ii + 1
38.       End With
39.     Case "AcDbMText1"
40.       Set MTt = AcadEnt
41.       Debug.Print "MText---", MTt.TextString
42.   End Select
43.   
44. Next
45.   ss1.Delete
46.   
47. End Sub
48. 在Excel中插入相应零件号，更改后面的件号，按顺序添加序号要比手动在AutoCAD中更改序号要简单多。
49. Sub ChangePartNumber()
50.   Dim Ent As AcadEntity
51.   Dim tt As AcadText
52.   Dim xlSheet
53.   Set xlSheet = xlApp.sheets(1)
54.   
55.   For ii = 1 To 50
56.     Set tt = ThisDrawing.ObjectIdToObject(xlSheet.cells(ii, 7).Value)
57.     With tt
58.       .TextString = xlSheet.cells(ii, 1).Value
59.       .color = acByLayer
60.       .Update
61.     End With
62.   Next ii
63. End Sub

Sub ReadPartNo()   Dim xlSheet   Set xlSheet = xlApp.sheets(1)   Dim ss1 As AcadSelectionSet   Dim layername As String   Dim AcadEnt As AcadEntity   'Dim pp1 As AcadPoint, pp2 As AcadPoint   '指定图层名称   'Set pp1 = ThisDrawing.Utility.GetPoint   'Set pp2 = ThisDrawing.Utility.GetPoint   layername = "件号"   Dim tt As AcadText, MTt As AcadMText   '得到选择集   Dim gpCode(0) As Integer   Dim dataValue(0) As Variant   gpCode(0) = 8   dataValue(0) = layername '  ss1.Delete   ii = 1   Set ss1 = ThisDrawing.SelectionSets.Add("sss")   ss1.Select acSelectionSetAll, , , gpCode, dataValue   'ss1.Select acSelectionSetCrossing, pp1, pp2, , dataValue For Each AcadEnt In ss1   'Debug.Print AcadEnt.ObjectName   Select Case AcadEnt.ObjectName     Case "AcDbText"       Set tt = AcadEnt       With tt         xlSheet.cells(ii, 1).Value = .TextString         xlSheet.cells(ii, 2).Value = .InsertionPoint(0)         xlSheet.cells(ii, 3).Value = .InsertionPoint(1)         xlSheet.cells(ii, 4).Value = .Layer         xlSheet.cells(ii, 5).Value = .ScaleFactor         xlSheet.cells(ii, 6).Value = .color         xlSheet.cells(ii, 7).Value = .ObjectID         ii = ii + 1       End With     Case "AcDbMText1"       Set MTt = AcadEnt       Debug.Print "MText---", MTt.TextString   End Select    Next   ss1.Delete    End Sub 在Excel中插入相应零件号，更改后面的件号，按顺序添加序号要比手动在<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>中更改序号要简单多。 Sub ChangePartNumber()   Dim Ent As AcadEntity   Dim tt As AcadText   Dim xlSheet   Set xlSheet = xlApp.sheets(1)      For ii = 1 To 50     Set tt = ThisDrawing.ObjectIdToObject(xlSheet.cells(ii, 7).Value)     With tt       .TextString = xlSheet.cells(ii, 1).Value       .color = acByLayer       .Update     End With   Next ii End Sub