solidworks列出单个文件的焊接清单

solidworks首先打开一个零件，然后运行此宏，此宏将焊接清单信息打印到立即窗口：

Option Explicit

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    
    If swModel.GetType() = swDocumentTypes_e.swDocPART Then
        Dim vCutLists As Variant
        vCutLists = GetCutLists(swModel)
        Debug.Print swModel.GetPathName
        ColorizeCutLists vCutLists
    Else
        Err.Raise vbError, "", "Only part document is supported"
    End If
    
End Sub


Sub ColorizeCutLists(vCutLists As Variant)
    
    Dim i As Integer
    
    For i = 0 To UBound(vCutLists)
        
        Dim swCutList As SldWorks.Feature
        Set swCutList = vCutLists(i)
        Dim swCutListPrpMgr As SldWorks.CustomPropertyManager
        Set swCutListPrpMgr = swCutList.CustomPropertyManager
        Dim outp As String
        outp = GetCutListItemString(swCutListPrpMgr)
        Debug.Print outp
    Next
    
End Sub

Function GetCutLists(model As SldWorks.ModelDoc2) As Variant
    Dim swFeat As SldWorks.Feature
    Dim swCutLists() As SldWorks.Feature
    Set swFeat = model.FirstFeature
    While Not swFeat Is Nothing
        If swFeat.GetTypeName2 <> "HistoryFolder" Then
            ProcessFeature swFeat, swCutLists
            TraverseSubFeatures swFeat, swCutLists
        End If
        Set swFeat = swFeat.GetNextFeature
    Wend
    
    GetCutLists = swCutLists
    
End Function

Sub TraverseSubFeatures(parentFeat As SldWorks.Feature, cutLists() As SldWorks.Feature)
    
    Dim swChildFeat As SldWorks.Feature
    Set swChildFeat = parentFeat.GetFirstSubFeature
    
    While Not swChildFeat Is Nothing
        ProcessFeature swChildFeat, cutLists
        Set swChildFeat = swChildFeat.GetNextSubFeature()
    Wend
    
End Sub

Sub ProcessFeature(feat As SldWorks.Feature, cutLists() As SldWorks.Feature)
    
    If feat.GetTypeName2() = "SolidBodyFolder" Then
        Dim swBodyFolder As SldWorks.BodyFolder
        Set swBodyFolder = feat.GetSpecificFeature2
        swBodyFolder.UpdateCutList
    ElseIf feat.GetTypeName2() = "CutListFolder" Then
        
        If Not Contains(cutLists, feat) Then
            If (Not cutLists) = -1 Then
                ReDim cutLists(0)
            Else
                ReDim Preserve cutLists(UBound(cutLists) + 1)
            End If
            
            Set cutLists(UBound(cutLists)) = feat
        End If
        
    End If
    
End Sub

Function Contains(arr As Variant, item As Object) As Boolean
    
    Dim i As Integer
    
    For i = 0 To UBound(arr)
        If arr(i) Is item Then
            Contains = True
            Exit Function
        End If
    Next
    
    Contains = False
    
End Function

Function GetCutListItemString(srcPrpMgr As SldWorks.CustomPropertyManager) As String
    Dim length As String
    length = GetProperty(srcPrpMgr, "长度")

    Dim spec As String
    spec = GetProperty(srcPrpMgr, "说明")

    Dim mat As String
    mat = GetProperty(srcPrpMgr, "MATERIAL")

    Dim quan As String
    quan = GetProperty(srcPrpMgr, "QUANTITY")

    GetCutListItemString = spec & vbTab & mat & vbTab & length & vbTab & quan

End Function


Function GetProperty(srcPrpMgr As SldWorks.CustomPropertyManager, prpName As String) As String
    Dim prpVal As String
    Dim prpResVal As String
    srcPrpMgr.Get5 prpName, False, prpVal, prpResVal, False
    GetProperty = prpResVal
End Function