SolidWorks一键生成BOM到Excel里，并可选择带缩略图

此前提到有粉丝朋友分享给我的一个VBA宏程序，能根据Solidworks装配体的零件属性一键导出到Excel，并可选择是否需要缩略图，零件的属性可以自定义，是一个很好的程序。但是试用后，发现有一些问题，其中最大的问题，也是很多粉丝朋友提到的一个问题，无法选择只导出子装配体或只导出子零件，它每次都把所有子装配体和所有子零件全部都导出来。还有一个问题是当装配体中含有轻化的零部件时，它会出错，无法正常运行。为此，我对该程序进行了改写，修正这些问题，并新增了一些实用功能，文末提供获取改进后的程序的方法。

改进后的程序界面如下图所示：

 

增加和修改的主要功能有以下这些：

1、允许用户选择是否显示子装配体及其子零件，当勾选“显示”时，子装配体及其子零件都显示，当勾选“隐藏”时，只显示子装配体，不显示其子零件，当勾选“提升”时，只显示子装配体内部各子零件，不显示子装配体本身，当勾选“自定义”时，则需要用户手工对每个子装配体进行设置，可以使每个子装配体的设置都不相同。如果同时勾选“更新配置”，则会把用户勾选的“显示”、“隐藏”、“提升”都设置到每一个装配体的对应配置里去。

2、增加了轻化零件可选择是否还原的功能，当检测到装配体中含有轻化装配体或零件时，会弹出提示框，询问用户是否将所有轻化装配体或零件还原，如果选择是，则自动将所有轻化的装配体及零件还原。如果选择否，则会把轻化装配体和零件当作被压缩的装配体或零件处理，BOM里不会出现它们的属性信息，但会在Excel表头里显示具体有多少个装配体或零件是轻化的。

3、增加“不同装配体中的相同零件分开列出”的选项，因为某些零件可能在不同的子装配体里重复出现，用户可以决定是否需要在BOM表里分开列出这些零件，如果选择不分开列出，那么这些零件的“所属装配号”对应的属性只能对应其中一个“所属装配号”。

4、增加了按属性排序的功能，并可选择“升序”、“降序”或“不排序”，但根装配体的属性不参与排序，根装配体始终位于BOM表的最前面。选择“不排序”时，子装配体后紧跟其对应的子零件。

5、使用WPS或Excel都可以适用程序，优先使用WPS。

6、质量属性设为固定属性，当质量小于10千克时，显示3位小数，当质量大于等于10千克小于100千克时，显示2位小数，当质量大于等于100千克小于1000千克时，显示1位小数，当质量大于等于1000千克时，不显示小数。

7、增加了“保存设置”按钮，用于保存用户的常用选项设置。

8、生成的Excel格式BOM默认保存在当前装配体相同路径下，与装配体的名称相同，可以选择更改保存的路径。

9、当切换活动装配体文档时，无须重新启动程序也可以直接导出新的活动装配体文档的BOM。

程序的总体设计思路是这样的：

1、首先采用递归的方法，遍历装配体中的所有零部件，检测是否有轻化的零件，如果检测到轻化的零件，则询问用户是否还原，如果用户选择还原，则进行还原，此步的具体代码如下：

'将轻化还原处理
Function resoveLightweight(ByVal Component As Object, ByVal level As Integer) As Boolean
    Dim i           As Integer
    Dim Children    As Variant
    Dim Child       As Object
    Dim ChildCount  As Integer
    
    If resoveLightWeightConfirmed = True Then
       If resove Then
            If Component.GetSuppression2 = 1 Then
                 Component.SetSuppression2 2
            End If
       End If
    ElseIf Component.GetSuppression2 = 1 Then
        If MsgBox("装配体中含有轻化零件，是否将其还原？选择“否”将把所有轻化零件当作压缩零件处理。", vbYesNo + vbQuestion, "询问") = vbYes Then
            resoveLightWeightConfirmed = True
            resove = True
            Component.SetSuppression2 2
        Else
            resoveLightWeightConfirmed = True
            resove = False
        End If
    End If
    
    Children = Component.GetChildren
    ChildCount = UBound(Children) + 1
    If Not isTopLevelOnly Or level = 0 Then  '不是只处理顶层，或当前是顶层时，递归
        For i = 0 To (ChildCount - 1)
            Set Child = Children(i)
            resoveLightweight Child, level + 1
        Next i
    End If
End Function

2、读取用户设置值，即用户在界面上勾选的各个选项和填写的参数，把这些选项和参数都读进全局变量里，此步的实现代码较简单，不需要专门解释。

3、根据用户选项，决定是否对子装配体的子零部件的显示方式进行更改，即修改子装配体配置里的“显示”、“隐藏”或“提升”，具体实现代码如下：

'子装配体内零部件可见性设置，opt=36  '显示  38隐藏，  292 '提升
Function setChildDisplayInBOM(ByVal assblDoc As ModelDoc2, ByVal parentConfig As String, ByVal opt As Long) As Boolean
    Dim components As Variant
    Dim config As String
    Dim parentModel, thisModelDoc As ModelDoc2
    Set parentModel = assblDoc
    Dim compnt As Variant

    parentModel.EditConfiguration3 parentConfig, parentConfig, "", "", opt  '设置零件的可见性
    components = parentModel.GetComponents(True) '括号里为true时只获取装配体内第一层的零部件名称，为false时，获取所有层级的零部件
    If Not IsEmpty(components) Then
      For Each compnt In components '遍历装配体
        '获取配置名
        config = compnt.ReferencedConfiguration
        Set thisModelDoc = compnt.GetModelDoc2
        If Not thisModelDoc Is Nothing Then
            If thisModelDoc.GetType = 2 Then
                setChildDisplayInBOM thisModelDoc, config, opt  '如果是装配体，则递归
            End If
        End If
      Next
    End If
End Function

4、遍历装配体：此步是最为关键的一步，因为要考虑的因素非常多，要考虑到零件是否轻化、是否压缩、是否封套、是否排除在BOM以外，如果是子装配体还要判断其子零件的显示方式是“隐藏”、“显示”或“提升”，还要考虑相同零件出现在不同子装配体的时候是否需要将其分开列出，在遍历的同时根据各种情况统计被压缩的零部件数量、不压缩的零件数量。这里采用2个全局字典对象变量dict1和dict2分别用于记录需要列出在Excel表中的零件数量(dict1记录数量）和零件component对象(dict2记录对象）。此步也是采用递归的方法进行遍历，具体实现代码如下：

'获得装配体内零部件的总数量
'showChildInBOM：1隐藏；2 显示；3 提升
Public Function CountComponents(ByVal Component As Object, ByVal level As Integer, ByVal showChildInBOM As Integer) As Long
    Dim i           As Integer
    Dim Children    As Variant
    Dim Child       As Object
    Dim ChildCount  As Integer
    Dim comptModel As ModelDoc2
    Dim refereceKey As String
    Dim parent As Object
    Dim showChild As Integer
    
    showChild = 2 '默认为显示
    
    If Component.IsSuppressed And isCountSupressed Then
        '如果组件压缩，累计压缩组件数量
        CountSupressed = CountSupressed + 1
    ElseIf Component.ExcludeFromBOM And Not isReadNoBomPart Then
        '累计被排除在统计表之外的零部件数量
        CountBOMexludedPart = CountBOMexludedPart + 1
    ElseIf Component.IsEnvelope And Not isReadNoBomPart Then
        '累计被封套的零部件数量
        CountBOMexludedPart = CountBOMexludedPart + 1
    Else
        Set comptModel = Component.GetModelDoc2
        If Not comptModel Is Nothing Then
            If comptModel.GetType = 1 Then
                CountNonSupressedPart = CountNonSupressedPart + 1
            Else
                CountNonSupressedAssbly = CountNonSupressedAssbly + 1
                
                '获取当前装配体配置的子零件显示方式
                If level = 0 Then
                    showChild = 2 '对于顶层，所有零件都要显示
                ElseIf Not isSavePartSetting Then  '如果不更新配置到子装配体
                    If isPartHide Then
                        showChild = 1
                    End If
                    If isPartPromote Then
                        showChild = 3
                    End If
                    If isPartCustom Then
                        showChild = showChildPartsInBOM(comptModel, Component.ReferencedConfiguration)
                    End If
                Else  '按实际显示方式
                    showChild = showChildPartsInBOM(comptModel, Component.ReferencedConfiguration)
                End If
                
            End If
            '是否需要将不同装配体中的相同零件分开列出
            refereceKey = Component.GetPathName & "`" & Component.ReferencedConfiguration
            If isSplitSameParts And level > 1 Then
                Set parent = Component.GetParent
                If Not parent Is Nothing Then
                    refereceKey = refereceKey & "`" & parent.GetPathName & "`" & parent.ReferencedConfiguration
                End If
            End If
            '非隐藏（显示或提升）时，添加零件
            If comptModel.GetType = 1 Then '对于零件，只要其父组件不是“隐藏”都要添加
                If showChildInBOM <> 1 Then
                    If Not dict1.exists(refereceKey) Then
                        dict1.Add refereceKey, 1
                        dict2.Add refereceKey, Component
                    Else
                        dict1(refereceKey) = dict1(refereceKey) + 1
                    End If
                'Else
                    'countHideParts = countHideParts + 1   '统计隐藏的零件
                End If
            Else  '对于装配体，只要其自身的配置设置不是“提升”都要添加
                If showChild <> 3 Then
                    If Not dict1.exists(refereceKey) Then
                        dict1.Add refereceKey, 1
                        dict2.Add refereceKey, Component
                    Else
                        dict1(refereceKey) = dict1(refereceKey) + 1
                    End If
                Else
                    countHideAsms = countHideAsms + 1   '统计隐藏的装配体
                    CountNonSupressedAssbly = CountNonSupressedAssbly - 1 '装配体数量减少重复计算
                End If
            End If
            
        End If
    End If
    Children = Component.GetChildren
    ChildCount = UBound(Children) + 1
    CountSubParts = CountSubParts + ChildCount
    If Not isTopLevelOnly Or level = 0 Then  '不是只处理顶层，或当前是顶层时，递归
        For i = 0 To (ChildCount - 1)
            Set Child = Children(i)
            If showChild <> 1 And Child.GetSuppression2 <> 1 Then   '当装配体的子零件设置为非隐藏且非轻化时，递归
                CountComponents Child, level + 1, showChild
            ElseIf Child.GetSuppression2 = 1 Then
                countLightWeightParts = countLightWeightParts + 1
            End If
        Next i
    End If
End Function

需要注意的是，在上面这段程序中，获取component对象的子对象时，使用了GetChildren方法，当component对象是一个压缩装配体时，GetChildren方法获取到的子对象为空，而如果component对象是一个轻化的装配体时，GetChildren方法获取到的子对象并不为空，这正是我所参考的宏程序没有考虑到的地方，因此当遇到轻化的子装配体时，会导致程序出错。我在上面这段程序中进行了改进，使用判断语句当child.getSuppression2=1（1表示轻化）时，统计装配体为轻化，且不再做递归处理。5、将结果写入Excel：在上一步的遍历代码中，dict2这个字典对象已经收集到了所有需要填写到Excel表中的零部件对象，接下来就是把dict2中的每个对象的对应属性获取到，并把属性值写入到Excel中。获取零件属性的方法如下：

'获取模型指定配置、指定属性名称对应的属性
'configName是配置名，如果为空字符，则为自定义属性
'propName是属性名称
Public Function getProperty(ByVal myModelDoc As ModelDoc2, ByVal configName As String, ByVal propName As String) As String
    Dim cusPropMgr As CustomPropertyManager
    Dim swModelDocExt As ModelDocExtension
    Dim ValOut As String
    Dim ResolvedValOut As String
    Dim WasResolved As Boolean
    
    Set swModelDocExt = myModelDoc.Extension
    Set cusPropMgr = swModelDocExt.CustomPropertyManager(configName)
    cusPropMgr.Get6 propName, False, ValOut, ResolvedValOut, False, False
    getProperty = ResolvedValOut
End Function

上面这段代码是获取“配置特定”或“自定义”的属性的，如果需要获取质量和密度属性，则使用另外一种方法，代码如下：

'构造自定义类型
Type MassType
    mass As Double
    density As Double
End Type
'获得模型质量和密度属性
Public Function GetMassProp(ByVal modelDoc As ModelDoc2, ByVal configName As String) As MassType
    Dim MassProp()    As Double
    Dim i             As Byte
    Dim Dummy         As Boolean
    Dim mass As Double
    Dim density As Double
    Dim mymass As MassType
    
    On Error GoTo ErrorHandler
    modelDoc.ShowConfiguration2 (configName)
    For i = 1 To 2
       MassProp = modelDoc.GetMassProperties
       If Not IsEmpty(MassProp) Then Exit For
       If i = 2 And IsEmpty(MassProp) Then GoTo ErrorHandler
       Dummy = modelDoc.Visible
       modelDoc.Visible = True
       modelDoc.Visible = Dummy
    Next
    mass = MassProp(5)
    density = MassProp(5) / MassProp(3) / 1000
    If mass > 1000 Then
        mass = FormatNumber(mass, 0) ' 四舍五入至小数点后0位
    ElseIf mass > 100 Then
        mass = FormatNumber(mass, 1) ' 四舍五入至小数点后1位
    ElseIf mass > 10 Then
        mass = FormatNumber(mass, 2) ' 四舍五入至小数点后2位
    Else
        mass = FormatNumber(mass, 3) ' 四舍五入至小数点后3位
    End If
    'mass = IIf(mass < "0.01", "0.01", mass) '最小重量10克
    density = FormatNumber(density, 2) ' 四舍五入至小数点后2位
    mymass.mass = mass
    mymass.density = density
    GetMassProp = mymass
    Exit Function
ErrorHandler:
    mymass.mass = -1
    mymass.density = -1
    GetMassProp = mymass
End Function

把这些属性写入到Excel的方法如下：

'写入Excel
Public Function write2Excel() As Boolean
    xlWs.Range("G1") = CountNonSupressedAssbly - 1 '减去母装配体
    xlWs.Range("G2") = CountNonSupressedPart
    xlWs.Range("G3") = CountSupressed
    xlWs.Range("G4") = CountBOMexludedPart
    xlWs.Range("C1") = countHideAsms
    xlWs.Range("C2") = countLightWeightParts
    
    Dim key As Variant
    Dim configName As String
    Dim pathName As String
    Dim i, j As Integer
    Dim modelMass As MassType
    Dim thisModel As ModelDoc2
    Dim parentCompt As Component2
    Dim PrevBMP As stdPicture
    
    i = 6
    For Each key In dict2.Keys
        pathName = Split(key, "`")(0)
        configName = Split(key, "`")(1)
        Set thisModel = dict2(key).GetModelDoc2
        If configName = "" Then
            configName = swModel.GetActiveConfiguration.Name  '对于母装配体，获取到的配置名为空，需要新获取
        End If
        xlWs.Range("A" & i) = pathName
        xlWs.Range("B" & i) = getFileName(pathName, 3)
        xlWs.Range("C" & i) = configName
        xlWs.Range("G" & i) = dict1(key)  '数量'
        modelMass = GetMassProp(thisModel, configName)  '获取重量属性
        xlWs.Range("E" & i) = modelMass.mass
        xlWs.Range("F" & i) = modelMass.density
        If Not isInsPic Then  '如果不插入图片或图片插入到批注列时，D列写装配或零件
            xlWs.Range("D" & i) = IIf(getFileName(pathName, 1) = "SLDASM", "装配", "零件")
        Else '如果需要插入缩略图片
            '调整D列的内容
            If Not isInsAnnotation Then  '如果要插入单元格
                xlWs.Range("D" & i).RowHeight = PicRangHeight
                xlWs.Range("D" & i).ColumnWidth = PicRangWidth
            Else '如果要插入图片到批注中
                xlWs.Range("D" & i) = IIf(getFileName(pathName, 1) = "SLDASM", "装配", "零件")
            End If
            
            If Not isFramePic Then  '如果非线框图
                InsertPic pathName, configName, i, 4
            Else  '线框图
                InsWireFramePic pathName, configName, i, 4
            End If
        End If
        
        
        '填写用户选定的属性
        For j = 9 To UBound(arr1) + 9
            If arr2(j - 9) = "配置特定" Then
                xlWs.Cells(i, j).value = getProperty(thisModel, configName, arr1(j - 9))
            Else
                xlWs.Cells(i, j).value = getProperty(thisModel, "", arr1(j - 9))
            End If
        Next
        xlWs.Cells(i, j).value = CDbl(xlWs.Cells(i, 5).value) * CInt(xlWs.Cells(i, 7).value)
        Set parentCompt = dict2(key).GetParent  '获得父组件
        If Not parentCompt Is Nothing Then
            If parentPropType = "配置特定" Then
                xlWs.Range("H" & i) = getProperty(parentCompt.GetModelDoc2, parentCompt.ReferencedConfiguration, parentPropName)
            Else
                xlWs.Range("H" & i) = getProperty(parentCompt.GetModelDoc2, "", parentPropName)
            End If
        Else  '无父组件，说明是顶层子部件
            If pathName <> strAsmFileName Then  '根装配体不填写
                If parentPropType = "配置特定" Then
                    xlWs.Range("H" & i) = getProperty(swModel, swModel.GetActiveConfiguration.Name, parentPropName)
                Else
                    xlWs.Range("H" & i) = getProperty(swModel, "", parentPropName)
                End If
            End If
        End If
        i = i + 1
    Next
    '自动调整列宽
    If isAutoFit Then
        xlWs.Columns("A:C").Columns.AutoFit
        xlWs.Columns("E:Z").Columns.AutoFit
    End If
    '文件全名列是否可见
    If Not isFileNameVisible Then
        xlWs.Columns("A:A").ColumnWidth = 0.1
    End If
    '排序
    '获取排序列编号
    If isItemInArr(UserForm1.ComboBox2.Text, fixPropName) > -1 Then
        sortColumn = isItemInArr(UserForm1.ComboBox2.Text, fixPropName) + 1
    ElseIf isItemInArr(UserForm1.ComboBox2.Text, arr1) > -1 Then
        sortColumn = isItemInArr(UserForm1.ComboBox2.Text, arr1) + 9
    ElseIf UserForm1.ComboBox2.Text = "总重" Then
        sortColumn = UBound(arr1) + 10
    Else
        sortColumn = 0
    End If
    '升降序排序
    If UserForm1.ComboBox3.Text = "升序" Then
        sortType = 1
    ElseIf UserForm1.ComboBox3.Text = "降序" Then
        sortType = 2
    Else
        sortType = 0
    End If
    If sortColumn > 0 And sortType > 0 Then
        With xlWs.Range(xlWs.Cells(7, 1), xlWs.Cells(i, UBound(arr1) + 10))
            .Sort Key1:=.Columns(sortColumn), Order1:=sortType
        End With
    End If
    
    xlApp.Visible = True
    '另存导出的文件
    xlWb.SaveAs FileName:=getFileName(strAsmFileName, 2) & getFileName(strAsmFileName, 0) & "BOM.xlsx", FileFormat:=51
    
End Function

本宏程序的swp文件已共享在网盘，如需下载，请关注微信公众号“全栈开发的码农”，点击“喜欢作者”，赞赏任意金额后，公众号会自动发送下载链接和提取码，如果仍未收到下载链接，可直接向公众号发送私信。