SolidWorks*Excel+VBA-BOM表,多阶/单阶

Sub GetBomTb() '材料明细表Dim swModelDoc As ModelDoc2, swModelDocFullNm As String, swModelDocNm As String, PropTitle As VariantDim PropVal As String, ModelMat As String, PropValRes As String, ActivConfig As String, fsNm As StringDim ReturnVal(), posn As Long, fsNames As Variant, AllModelNmDic As Dictionary, Multi As Boolean, msgtyp As Variant    If myselcondi Then        posn = Selarray(1): SetGolDic        With ThisWorkbook.ActiveSheet            If UCase(.Cells(posn, PropTitDicA("扩展名"))) <> ".SLDASM" Then                MsgBox "未选择装配,程序结束!", vbExclamation, "不正经的机械仙人"                Exit Sub            End If            msgtyp = MsgBox("请选择材料明细表类型:" & Chr(13) & _                     "点击 [是(Y)] 展开为多阶, [否(N)] 展开为单阶。", vbQuestion + vbYesNoCancel, "不正经的机械仙人")            If msgtyp = vbYes Then                Multi = True            ElseIf msgtyp = vbNo Then                Multi = False            Else                Exit Sub            End If            fsNm = .Cells(posn, PropTitDicA("文件位置")) & "\" & .Cells(posn, PropTitDicA("SW模型文件名")) & .Cells(posn, PropTitDicA("扩展名"))        End With        ReturnVal = OpenDsFiles_next("model", posn)        If VarType(ReturnVal(0)) <> vbEmpty Then            ThisWorkbook.Sheets("SW3 材料明细表").Activate            Set swModelDoc = ReturnVal(0): swModelDocFullNm = swModelDoc.GetPathName: swModelDocNm = swModelDoc.GetTitle            ActivConfig = swModelDoc.ConfigurationManager.ActiveConfiguration.Name            Set AllModelNmDic = CreateObject("Scripting.Dictionary")            Application.StatusBar = "正在展开:" & swModelDocFullNm            With ThisWorkbook.ActiveSheet                .AutoFilter.ShowAllData: .Range("A3:Z10000").ClearContents                .Cells(3, PropTitDicA("文件全名")) = swModelDocFullNm                .Cells(3, PropTitDicA("文件位置")) = Left(swModelDocFullNm, InStrRev(swModelDocFullNm, "\") - 1)                .Cells(3, PropTitDicA("SW模型文件名")) = Left(swModelDocNm, InStrRev(swModelDocNm, ".") - 1)                .Cells(3, PropTitDicA("扩展名")) = UCase(Mid(swModelDocNm, InStrRev(swModelDocNm, ".")))                .Cells(3, PropTitDicA("阶层")) = "S1"                .Cells(3, PropTitDicA("当前配置")) = ActivConfig                swModelDoc.Extension.CustomPropertyManager(ActivConfig).Get2 "材料", PropVal, ModelMat                .Cells(3, PropTitDicA("材质")) = ModelMat                .Cells(3, PropTitDicA("数量")) = 1                For Each PropTitle In PropTitDicB.Keys                    swModelDoc.Extension.CustomPropertyManager(ActivConfig).Get2 PropTitle, PropVal, PropValRes                    .Cells(3, PropTitDicB(PropTitle)) = PropValRes                    PropValRes = ""                Next            End With            AllModelNmDic.Add swModelDocFullNm, 3            GetBomTb_Next swModelDoc, 4, Multi, AllModelNmDic, 1 '递归搜索            Set AllModelNmDic = Nothing            Application.StatusBar = False            swApp.QuitDoc swModelDocFullNm            MsgBox fsNm & " 材料明细表已搜索整理完毕!", vbInformation, "不正经的机械仙人"        Else            MsgBox fsNm & Chr(13) & "打开失败!", vbExclamation, "不正经的机械仙人"        End If    Else        MsgBox "未选择正确行,程序结束!", vbExclamation, "不正经的机械仙人"    End IfEnd SubSub GetBomTb_Next(ParaModel As ModelDoc2, i As Long, Multi As Boolean, Optional AllModelNmDic As Dictionary, Optional dep As String) '递归展开材料明细表Dim Comps As Variant, Comp As Variant, ChiModel As ModelDoc2, PartModel As PartDoc, SouRow As LongDim ModelNmDic As Dictionary, ChiModelFullNm As String, ChiModelNm As String, j As LongDim PropVal As String, ModelMat As String, PropValRes As String, ActivConfig As String, PropTitle As Variant    ParaModel.ResolveAllLightWeightComponents False '解除轻化    Comps = ParaModel.GetComponents(True)    Set ModelNmDic = CreateObject("Scripting.Dictionary")    With ThisWorkbook.ActiveSheet    j = 1        For Each Comp In Comps            If Not (Comp.IsSuppressed Or Comp.ExcludeFromBOM) Then '未压缩且未被排除                Set ChiModel = Comp.GetModelDoc2: ChiModelFullNm = ChiModel.GetPathName: ChiModelNm = ChiModel.GetTitle                ActivConfig = ChiModel.ConfigurationManager.ActiveConfiguration.Name                Select Case Multi                Case True '展开为多阶                    If Not ModelNmDic.Exists(ChiModelFullNm) Then '单个装配内，不重复搜索子阶                        Application.StatusBar = "正在展开:" & ChiModelFullNm                        ModelNmDic.Add ChiModelFullNm, i                        .Cells(i, PropTitDicA("文件全名")) = ChiModelFullNm                        .Cells(i, PropTitDicA("文件位置")) = Left(ChiModelFullNm, InStrRev(ChiModelFullNm, "\") - 1)                        .Cells(i, PropTitDicA("SW模型文件名")) = Left(ChiModelNm, InStrRev(ChiModelNm, ".") - 1)                        .Cells(i, PropTitDicA("扩展名")) = UCase(Mid(ChiModelNm, InStrRev(ChiModelNm, ".")))                        .Cells(i, PropTitDicA("阶层")) = "S" & dep & "." & j                        .Cells(i, PropTitDicA("当前配置")) = ActivConfig                        .Cells(i, PropTitDicA("数量")) = 1                        For Each PropTitle In PropTitDicB.Keys                            ChiModel.Extension.CustomPropertyManager(ActivConfig).Get2 PropTitle, PropVal, PropValRes                            .Cells(i, PropTitDicB(PropTitle)) = PropValRes                            PropValRes = ""                        Next                        i = i + 1                        If ChiModel.GetType = swDocASSEMBLY Then                            ChiModel.Extension.CustomPropertyManager(ActivConfig).Get2 "材料", PropVal, ModelMat                            .Cells(i - 1, PropTitDicA("材质")) = ModelMat                            GetBomTb_Next ChiModel, i, Multi, , dep & "." & j '递归展开                        Else                            Set PartModel = ChiModel                            ModelMat = PartModel.GetMaterialPropertyName2(ActivConfig, "")                            .Cells(i - 1, PropTitDicA("材质")) = ModelMat                            Set PartModel = Nothing                        End If                        j = j + 1                    Else                        SouRow = ModelNmDic.Item(ChiModelFullNm)                        .Cells(SouRow, PropTitDicA("数量")) = .Cells(SouRow, PropTitDicA("数量")) + 1                    End If                Case False '展开为单阶                    If Not AllModelNmDic.Exists(ChiModelFullNm) Then '全局唯一                        Application.StatusBar = "正在展开:" & ChiModelFullNm                        AllModelNmDic.Add ChiModelFullNm, i                        .Cells(i, PropTitDicA("文件全名")) = ChiModelFullNm                        .Cells(i, PropTitDicA("文件位置")) = Left(ChiModelFullNm, InStrRev(ChiModelFullNm, "\") - 1)                        .Cells(i, PropTitDicA("SW模型文件名")) = Left(ChiModelNm, InStrRev(ChiModelNm, ".") - 1)                        .Cells(i, PropTitDicA("扩展名")) = UCase(Mid(ChiModelNm, InStrRev(ChiModelNm, ".")))                        .Cells(i, PropTitDicA("阶层")) = "S1"                        .Cells(i, PropTitDicA("当前配置")) = ActivConfig                        .Cells(i, PropTitDicA("数量")) = 1                        For Each PropTitle In PropTitDicB.Keys                            ChiModel.Extension.CustomPropertyManager(ActivConfig).Get2 PropTitle, PropVal, PropValRes                            .Cells(i, PropTitDicB(PropTitle)) = PropValRes                            PropValRes = ""                        Next                        If ChiModel.GetType = swDocASSEMBLY Then                            ChiModel.Extension.CustomPropertyManager(ActivConfig).Get2 "材料", PropVal, ModelMat                            .Cells(i, PropTitDicA("材质")) = ModelMat                        Else                            Set PartModel = ChiModel                            ModelMat = PartModel.GetMaterialPropertyName2(ActivConfig, "")                            .Cells(i, PropTitDicA("材质")) = ModelMat                            Set PartModel = Nothing                        End If                        i = i + 1                    Else                        SouRow = AllModelNmDic.Item(ChiModelFullNm)                        .Cells(SouRow, PropTitDicA("数量")) = .Cells(SouRow, PropTitDicA("数量")) + 1                    End If                    If ChiModel.GetType = swDocASSEMBLY Then GetBomTb_Next ChiModel, i, Multi, AllModelNmDic '递归展开                End Select            End If        Next    End With    Set ModelNmDic = Nothing    Set Comp = Nothing    Set Comps = Nothing    Set ChiModel = Nothing    Set ParaModel = NothingEnd Sub