【遍历宏】在总装配內零件的自定义属性写入页码 - iCAx开思网

Dim TopDocPathOnly As String
Dim PartsCollect() As String '遍历清单（阵列）
Dim InCollectCount As Double '遍历清单长度
Dim CustomInfoQTY As String
'*******************************************************
Dim Page_Qty As String
Dim Page_Pre As String
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swConfig As SldWorks.Configuration
Dim CustPropMgr As SldWorks.CustomPropertyManager
Sub main()
Answer = MsgBox("① 本程序将遍历装配体填写“页码”属性，请确认顶层装配体已保存！" & Chr(13) & "② 不在顶层装配体目录或子目录、压缩、轻化、虚拟、封套、不包括在BOM中的零部件不作处理。", vbOKCancel + 48)
If Answer = vbOK Then
Set swApp = Application.SldWorks 'SW对象
Set TopDoc = swApp.ActiveDoc '顶层装配体对象
If TopDoc.GetType <> 2 Then Exit Sub '如果不是装配体则退出
TopDocPathSplit = Split(TopDoc.GetPathName, "") '分割
TopDocName = TopDocPathSplit(UBound(TopDocPathSplit)) '顶层装配体文件名称
TopDocName = Left(TopDocName, Len(TopDocName) - 7) '顶层装配体文件名称（排除.SLDASM）
TopDocPathOnly = Mid(TopDoc.GetPathName, 1, InStrRev(TopDoc.GetPathName, "", -1)) '顶层装配体的完整目录
TopConfString = TopDoc.GetActiveConfiguration.Name '顶层装配体配置名称
CustomInfoQTY = "配套数量" '可根据需要改为其它
Page_Qty = 1 '页码递增基数
InCollectCount = 1 '遍历清单长度基数
ReDim PartsCollect(InCollectCount) '定义阵列项数
Else: Exit Sub
End If
'*******************************************************
Page_Pre = InputBox("输入页码前缀再按“确定”，无前缀请按任意键。")
Set TopCustPropMgr = TopDoc.Extension.CustomPropertyManager("")
TopCustPropMgr.Delete ("页码")
TopCustPropMgr.Add2 "页码", swCustomInfoText, Page_Pre & "" & "1" '指定顶层装配体的页码为“1”
'*******************************************************
SubAsm TopDoc, TopConfString '遍历
Beep '响铃
End Sub
Function SubAsm(AsmDoc, ConfString)
Set Configuration = AsmDoc.GetConfigurationByName(ConfString)
Set RootComponent = Configuration.GetRootComponent
Components = RootComponent.GetChildren
For Each Child In Components
Set ChildModel = Child.GetModelDoc
If Not (ChildModel Is Nothing) Then '排除压缩及轻化
ChildConfString = Child.ReferencedConfiguration '零件配置名称
ChildType = ChildModel.GetType
ChildPathSplit = Split(Child.GetPathName, "") '分割
ChildName = ChildPathSplit(UBound(ChildPathSplit)) '零件文件名称
ChildPathOnly = Mid(Child.GetPathName, 1, InStrRev(Child.GetPathName, "", -1)) '零件的完整目录
If ChildPathOnly = Replace(ChildPathOnly, TopDocPathOnly, "") Then SamePath = False Else SamePath = True '零件是否在顶层装配体目录或子目录中
If SamePath And (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then '跳过：不在顶层装配体目录或子目录及不包括在BOM中及封套
'If (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then '跳过：不包括在BOM中及封套
UNIT_OF_MEASURE_Name = ChildModel.CustomInfo2("", "UNIT_OF_MEASURE") '备用量属性名称
UNIT_OF_MEASURE = ChildModel.CustomInfo2("", UNIT_OF_MEASURE_Name) '备用量
If (UNIT_OF_MEASURE = 0) Or (UNIT_OF_MEASURE = "") Then UNIT_OF_MEASURE = 1 '备用量除错
inCollect = False '重置判断变量
For Each PartinCollect In PartsCollect '判断是否已在遍历清单内
If "" & "@" & ChildName = PartinCollect Then inCollect = True
Next
If inCollect Then '已在遍历清单内
' ht_Qty = ChildModel.CustomInfo2("", CustomInfoQTY) + 1 * UNIT_OF_MEASURE
' ChildModel.DeleteCustomInfo2 "", CustomInfoQTY
' ChildModel.AddCustomInfo3 "", CustomInfoQTY, 30, ht_Qty
Else '不在遍历清单内（首次处理）
' ChildModel.DeleteCustomInfo2 "", CustomInfoQTY
' ChildModel.AddCustomInfo3 "", CustomInfoQTY, 30, UNIT_OF_MEASURE
InCollectCount = InCollectCount + 1 '遍历清单长度基数+1
ReDim Preserve PartsCollect(InCollectCount) '重新定义阵列项数（保留内含数据）
PartsCollect(InCollectCount - 1) = "" & "@" & ChildName '加入到遍历清单中
'*******************************************************
Set CustPropMgr = ChildModel.Extension.CustomPropertyManager("")
Page_Qty = Page_Qty + 1
ChildModel.DeleteCustomInfo2 "", ("页码")
ChildModel.AddCustomInfo3 "", ("页码"), 30, Page_Pre & Page_Qty
'*******************************************************
ChildModel.SketchManager.Insert3DSketch True '插入3D草图，从而激活零件的“需存盘标签”
ChildModel.SketchManager.Insert3DSketch True '离开3D草图
End If
If ChildType = 2 Then
SubAsm ChildModel, ChildConfString '如果是装配体则向下遍历
End If
End If
End If
Next
End Function

复制代码

Dim swApp As SldWorks.SldWorks
Dim swDoc As SldWorks.ModelDoc2
Dim longstatus As Long
Dim longwarnings As Long
Dim PathName As String
Dim FilePath As String
Dim FullFileName As String
Dim swDocName As String
Dim swDocType As Long
Dim fso As New Scripting.FileSystemObject
Dim MYext As String
Sub main()
On Error Resume Next
Set swApp = Application.SldWorks
FilePath = InputBox("本程序将向指定路径下的模型文件填写“页码”属性。" & Chr(13) & "请输入或粘贴完整路径后按“确定”。")
If FilePath = "" Then Exit Sub
FilePath = FilePath & ""
BatchFolder FilePath, ".SLDPRT", ".SLDASM", True
End Sub
'批量处理文件夹的递归过程
Sub BatchFolder(folder As String, ext As String, ext2 As String, silent As Boolean)
Dim swModelDocExt As ModelDocExtension
Dim swCustProp As CustomPropertyManager
Dim Page_Pre As String
Dim Page_Qty As String
If Right(folder, 1) <> "" Then folder = folder & ""
ChDir (folder)
PathName = Dir(folder)
Page_Pre = InputBox("请输入页码的前缀再按“确定”，无前缀按任意键。")
Page_Qty = 0 '页码递增基数
Do Until PathName = ""
FullFileName = folder & PathName
MYext = Right(UCase$(PathName), 7)
If MYext = ext Or MYext = ext2 Then '如果这个文件类型是所需的，就进行处理
swDocType = Switch(MYext = ".SLDPRT", swDocPART, MYext = ".SLDDRW", swDocDRAWING, MYext = ".SLDASM", swDocASSEMBLY, True, -1)
Set swDoc = swApp.OpenDoc6(FullFileName, swDocType, swOpenDocOptions_Silent, "", longstatus, longwarnings)
Set swDoc = swApp.ActiveDoc
swDocName = Mid(swDoc.GetPathName, InStrRev(swDoc.GetPathName, "") + 1)
swDocName = Left(swDocName, InStrRev(swDocName, ".") - 1)
Page_Qty = Page_Qty + 1 '页码递增基数+1
swDoc.DeleteCustomInfo2 "", ("底图张次")
swDoc.AddCustomInfo3 "", ("底图张次"), 30, Page_Pre & Page_Qty
swDoc.Save '保存
swApp.CloseDoc swDoc.GetTitle '关闭文件
Set swDoc = Nothing
End If
PathName = Dir
Loop
'如果有子文件夹，进行递归处理
' Dim myFolder As folder
' Dim mySub As folder
'
' Set myFolder = fso.GetFolder(folder)
' For Each mySub In myFolder.SubFolders
' BatchFolder mySub.Path, ext, ext2, silent
' Next
End Sub

复制代码