Dim TopDocPathOnly As String
Dim PartsCollect() As String '遍歷清單（陣列）
Dim InCollectCount As Double '遍歷清單長度
Dim CustomInfoQTY As String
Sub main()
Set swApp = Application.SldWorks '騷窩對象
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 = TopDocPathSplit(UBound(TopDocPathSplit) - 1) '總裝目錄名稱
TopConfString = TopDoc.GetActiveConfiguration.Name '總裝配置名稱
CustomInfoQTY = InputBox("自定義屬性名稱", "遍歷" & TopDocName, "用於" & TopDocName & "的數量") '可按個人喜好修改預設值
If CustomInfoQTY = "" Then Exit Sub '按下取消離開宏
InCollectCount = 1 '遍歷清單長度基數
ReDim PartsCollect(InCollectCount) '定義陣列項數
SubAsm TopDoc, TopConfString '遍歷
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
If ChildType = 2 Then
SubAsm ChildModel, ChildConfString '如果是裝配則向下遍歷
Else
ChildPathSplit = Split(Child.GetPathName, "") '分割
ChildName = ChildPathSplit(UBound(ChildPathSplit)) '零件文件名稱
ChildPathOnly = ChildPathSplit(UBound(ChildPathSplit) - 1) '零件目錄名稱
If ChildPathOnly = TopDocPathOnly Then SamePath = True Else SamePath = False '是否在總裝目錄
If SamePath And (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then '跳過：不在總裝目錄 及 不包括在材料明細表中 及 封套
UNIT_OF_MEASURE_Name = ChildModel.CustomInfo2(ChildConfString, "UNIT_OF_MEASURE") '備用量屬性名稱
UNIT_OF_MEASURE = ChildModel.CustomInfo2(ChildConfString, 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 ChildConfString & "@" & ChildName = PartinCollect Then inCollect = True
Next
If inCollect Then '已在遍歷清單內
ht_Qty = ChildModel.CustomInfo2(ChildConfString, CustomInfoQTY) + 1 * UNIT_OF_MEASURE
ChildModel.DeleteCustomInfo2 ChildConfString, CustomInfoQTY
ChildModel.AddCustomInfo3 ChildConfString, CustomInfoQTY, 30, ht_Qty
Else '不在遍歷清單內（首次處理）
ChildModel.DeleteCustomInfo2 ChildConfString, CustomInfoQTY
ChildModel.AddCustomInfo3 ChildConfString, CustomInfoQTY, 30, UNIT_OF_MEASURE
InCollectCount = InCollectCount + 1
ReDim Preserve PartsCollect(InCollectCount) '重新定義陣列項數（保留內含數據）
PartsCollect(InCollectCount - 1) = ChildConfString & "@" & ChildName '加入到遍歷清單中
ChildModel.SetUserPreferenceIntegerValue swUnitsMassPropMass, swUnitsMassPropMass_Kilograms '單位設定為kg（可按喜好加入設定）
End If
End If
End If
End If
Next
End Function
，
。
路过，来看看，支持楼主{:3_58:}