SolidWorks*Excel+VBA-关于拉取BOM提速

Sub 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 Long, k As Long, m As LongDim PropNms As Variant, PropTps As Variant, PropVal As Variant, PropValRes As VariantDim ModelMat As String, ActivConfig As String, PropTmp As String, PropRng As Range, ValArr()    ParaModel.ResolveAllLightWeightComponents False '解除轻化    Comps = ParaModel.GetComponents(True)    Set ModelNmDic = CreateObject("Scripting.Dictionary")    With ThisWorkbook.ActiveSheet        j = 1        ReDim Preserve ValArr(PropTitDicA.Count + PropTitDicB.Count - 2) '排除第一列，数组下标从0开始        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 = "正在汇算多阶BOM:" & ChiModelFullNm                        ModelNmDic.Add ChiModelFullNm, i                        Set PropRng = .Range("B" & i).Resize(1, UBound(ValArr) + 1)                        ChiModel.Extension.CustomPropertyManager(ActivConfig).GetAll2 PropNms, PropTps, PropVal, PropValRes                        For m = 0 To UBound(ValArr)                            Select Case .Cells(1, m + 2).Value                            Case "文件全名": ValArr(m) = ChiModelFullNm                            Case "文件位置": ValArr(m) = Left(ChiModelFullNm, InStrRev(ChiModelFullNm, "\") - 1)                            Case "SW模型文件名": ValArr(m) = Left(ChiModelNm, InStrRev(ChiModelNm, ".") - 1)                            Case "扩展名": ValArr(m) = UCase(Mid(ChiModelNm, InStrRev(ChiModelNm, ".")))                            Case "阶层": ValArr(m) = "S" & dep & "." & j                            Case "当前配置": ValArr(m) = ActivConfig                            Case "数量": ValArr(m) = 1                            Case "材质"                                If ChiModel.GetType = swDocASSEMBLY Then                                    ChiModel.Extension.CustomPropertyManager(ActivConfig).Get2 "材料", PropTmp, ModelMat                                Else                                    Set PartModel = ChiModel                                    ModelMat = PartModel.GetMaterialPropertyName2(ActivConfig, "")                                    Set PartModel = Nothing                                End If                                ValArr(m) = ModelMat                            Case Else                                If VarType(PropNms) <> vbEmpty Then                                    k = GetRefVal(.Cells(1, m + 2).Value, PropNms)                                    If k <> 0 Then ValArr(m) = PropVal(k - 1)                                End If                            End Select                        Next                        PropRng.Value = ValArr: ReDim ValArr(UBound(ValArr))                        i = i + 1                        If ChiModel.GetType = swDocASSEMBLY Then GetBomTb_Next ChiModel, i, Multi, , dep & "." & j '递归展开                        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 = "正在汇算单阶BOM:" & ChiModelFullNm                        AllModelNmDic.Add ChiModelFullNm, i                        Set PropRng = .Range("B" & i).Resize(1, UBound(ValArr) + 1)                        ChiModel.Extension.CustomPropertyManager(ActivConfig).GetAll2 PropNms, PropTps, PropVal, PropValRes                        For m = 0 To UBound(ValArr)                            Select Case .Cells(1, m + 2).Value                            Case "文件全名": ValArr(m) = ChiModelFullNm                            Case "文件位置": ValArr(m) = Left(ChiModelFullNm, InStrRev(ChiModelFullNm, "\") - 1)                            Case "SW模型文件名": ValArr(m) = Left(ChiModelNm, InStrRev(ChiModelNm, ".") - 1)                            Case "扩展名": ValArr(m) = UCase(Mid(ChiModelNm, InStrRev(ChiModelNm, ".")))                            Case "阶层": ValArr(m) = "S1"                            Case "当前配置": ValArr(m) = ActivConfig                            Case "数量": ValArr(m) = 1                            Case "材质"                                If ChiModel.GetType = swDocASSEMBLY Then                                    ChiModel.Extension.CustomPropertyManager(ActivConfig).Get2 "材料", PropTmp, ModelMat                                Else                                    Set PartModel = ChiModel                                    ModelMat = PartModel.GetMaterialPropertyName2(ActivConfig, "")                                    Set PartModel = Nothing                                End If                                ValArr(m) = ModelMat                            Case Else                                If VarType(PropNms) <> vbEmpty Then                                    k = GetRefVal(.Cells(1, m + 2).Value, PropNms)                                    If k <> 0 Then ValArr(m) = PropVal(k - 1)                                End If                            End Select                        Next                        PropRng.Value = ValArr: ReDim ValArr(UBound(ValArr))                        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