[原创]借助Excel更改零件号
本帖最后由 作者 于 2007-12-10 15:28:28 编辑绘制施工图时，在件号1~50之间补插入17和18零件号，通常方法是人工来更改后面零件号。如图所示。
本人的解决方案是，将施工图里的件号图层的件号读到到Excel中，在Excel中1~50间的17、18后，插入19、20件号。采用ObjectToObject更改原施工图里件号，效率高，实用性强。程序如下。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中插入相应零件号，更改后面的件号，按顺序添加序号要比手动在AutoCad中更改序号要简单多。
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
页:
[1]