AnsweredAssumed Answered

Custom property don't save in each part

Question asked by Mikael Bolduc on Dec 23, 2015
Latest reply on Dec 24, 2015 by Mikael Bolduc

I have a problem with my macro.

In my assembly, I play my macro for change/add custom property to my part. (Work good)

But, It didn't save the change/add in each part. So when i close the file and i open it after, i lost all my property that i had put.

So, what can i do to save each part in the assembly?


Thank you


Option Explicit

'Global SolidWorks Application variables
    Public swApp As SldWorks.SldWorks  'SolidWorks application
    Public swModel As SldWorks.ModelDoc2  'File to be processed
    Public swCustPropMgr As SldWorks.CustomPropertyManager  'Custom Property Manager
    Public lngRetVal As Long  'Debugging variable
Sub TraverseComponent(swComp As SldWorks.Component2)
    Dim vChildComps As Variant
    Dim swChildComp As SldWorks.Component2
    Dim swModelComp As ModelDoc2
    Dim vIsSuppressed As Variant
    Dim i As Long
'Get array of sub components
    vChildComps = swComp.GetChildren
'Step through all sub components
    For i = 0 To UBound(vChildComps)
    'Get current Component
        Set swChildComp = vChildComps(i)
    'Check if the current Component is suppressed
        vIsSuppressed = swChildComp.IsSuppressed

        If Not vIsSuppressed Then  'Verify the Component is not suppressed
        'Print current Component name
            Debug.Print swChildComp.Name2 & " <" & swChildComp.ReferencedConfiguration & ">"
        'Get model for current Component
            Set swModelComp = swChildComp.GetModelDoc2
            If swModelComp.GetType = swDocPART Then  'Check if current Component is a Part
            'Get Custom Property Manager
                Set swCustPropMgr = swModelComp.Extension.CustomPropertyManager(swChildComp.ReferencedConfiguration)
                Call TraverseFeatures(swChildComp.FirstFeature, True, "Root Feature") 'Step through component features
            End If
            Call TraverseComponent(swChildComp)  'Step though sub components
        End If
    Next i
End Sub


Sub TraverseFeatures(swThisFeat As SldWorks.Feature, bIsTopLevel As Boolean, strParentName As String)
    Dim swCurFeat As SldWorks.Feature
    Dim swSubFeat As SldWorks.Feature
    Dim swNextSubFeat As SldWorks.Feature

'Get the current feature
    Set swCurFeat = swThisFeat
'Verify the feature exists
    While Not swCurFeat Is Nothing
'Debug.Print swCurFeat.Name & " - " & swCurFeat.GetTypeName2

        Call ProcessFeature(swCurFeat, strParentName)  'Process the current feature
    'Get first feature under the current feature
        Set swSubFeat = swCurFeat.GetFirstSubFeature
    'Verify the subfeature exists
        While Not swSubFeat Is Nothing
            Call TraverseFeatures(swSubFeat, False, swCurFeat.Name) 'Step through subfeatures
        'Get Sub-Feature of current sub-feature
            Set swSubFeat = swSubFeat.GetNextSubFeature
        If bIsTopLevel Then  'Check if current feature is a Top Level feature
        'Get next feature
            Set swCurFeat = swCurFeat.GetNextFeature
        Else  'If not a Top Level feature
        'Set current feature to Nothing to exit the current loop
            Set swCurFeat = Nothing
        End If
End Sub


Sub ProcessFeature(swFeat As SldWorks.Feature, strParentName As String)
    Dim strFeatType As String
    Dim BodyFolder As SldWorks.BodyFolder
    Dim vBodies As Variant
    Static bInBodyFolder As Boolean
    Dim i As Long

'Get type of current feature
    strFeatType = swFeat.GetTypeName2
    If (strFeatType = "SolidBodyFolder") And (strParentName = "Root Feature") Then
        bInBodyFolder = True
    End If
    If (strFeatType <> "SolidBodyFolder") And (strParentName = "Root Feature") Then
        bInBodyFolder = False
    End If
    If (bInBodyFolder = False) And (strFeatType = "CutListFolder") Then    'Only consider the CutListFolders that
        'are under the SolidBodyFolder
        Exit Sub    'Skip the second occurrence of the CutListFolders during the feature traversal
    End If
    If strFeatType = "SolidBodyFolder" Or strFeatType = "CutListFolder" Then  'Check if current feature is a Body folder
    'Get the Body folder
        Set BodyFolder = swFeat.GetSpecificFeature2
        If (strFeatType = "CutListFolder") And (BodyFolder.GetBodyCount < 1) Then
            Exit Sub   'When Body count = 0, this cut list folder is not displayed in the
                        'Feature Manager design Tree, so skip it
        End If
    'Get the Bodies in this folder
        vBodies = BodyFolder.GetBodies
        If Not IsEmpty(vBodies) Then  'Verify the Bodies exist
        'Step through the array of Bodies
            For i = LBound(vBodies) To UBound(vBodies)
                Call ProcessBody(vBodies(i))  'Process the current Body
            Next i
        End If
    End If
End Sub


Sub ProcessBody(vBody As Variant)
    Dim swBody As SldWorks.Body2
    Dim vFeatures As Variant
    Dim vFeature As Variant
    Dim swBodyFeat As SldWorks.Feature
    Dim lngFeatCount As Long
    Dim Matériaux1 As String
    Dim DESCRIPTION1 As String
'Get current Body
    Set swBody = vBody
'Get Features attached to current Body
    vFeatures = swBody.GetFeatures
'Count features in current Body
    lngFeatCount = UBound(vFeatures) + 1
'Step through Body features
    For Each vFeature In vFeatures
    'Get current feature
        Set swBodyFeat = vFeature
      Matériaux1 = swCustPropMgr.Get("MATÉRIAU")
      DESCRIPTION1 = swCustPropMgr.Get("DESCRIPTION")
    If Matériaux1 = "" And DESCRIPTION1 = "" Then GoTo End1
    'Check for Sheet Metal features
        If swBodyFeat.GetTypeName2 = "SheetMetal" Then
        lngRetVal = swCustPropMgr.Delete("DÉTAIL")
        lngRetVal = swCustPropMgr.Add2("DÉTAIL", swCustomInfoText, "PLASMA")
        lngRetVal = swCustPropMgr.Delete("LONGUEUR")
        lngRetVal = swCustPropMgr.Add2("LONGUEUR", swCustomInfoText, "-")
            Exit Sub
        End If
    Next vFeature

    If lngFeatCount > 1 Then  'Check if more than one feature exists
    'Add Usinage custom property
        lngRetVal = swCustPropMgr.Delete("DÉTAIL")
        lngRetVal = swCustPropMgr.Add2("DÉTAIL", swCustomInfoText, "USINAGE")
    End If

End Sub


Sub main()
    Dim swConfig As SldWorks.Configuration
    Dim swRootComp As SldWorks.Component2

'Get SolidWorks application
    Set swApp = Application.SldWorks
'Get current document
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then  'Check if a file is currently open
    'Send message to user that no files are currently open
        swApp.SendMsgToUser2 "Please open an assembly or part file.", swMbStop, swMbOk
        Debug.Print "**No files open - Macro Canceled**"
    ElseIf swModel.GetType = swDocDRAWING Then  'Check if active file is a Drawing
    'Display message
        swApp.SendMsgToUser2 "Please open an assembly or part file.", swMbStop, swMbOk
        Debug.Print "**Macro Canceled** - Not an Assembly or Part File"
    'End macro
    End If
'Show file path
    Debug.Print "File = " & swModel.GetPathName
    If swModel.GetType = swDocASSEMBLY Then  'Check if active file is an Assembly
    'Get current Configuration
        Set swConfig = swModel.GetActiveConfiguration
    'Get first Component
        Set swRootComp = swConfig.GetRootComponent3(True)
        Call TraverseComponent(swRootComp)  'Step through assembly components
    Else  'If active file is a Par
    'Get Custom Property Manager
        Set swCustPropMgr = swModel.Extension.CustomPropertyManager(swModel.ConfigurationManager.ActiveConfiguration.Name)
        Call TraverseFeatures(swModel.FirstFeature, True, "Root Feature")  'Step through the feature tree
    End If

'Message user that macro has completed
    swApp.SendMsgToUser2 "DÉTAIL USINAGE ET PLASMA CHECK!", swMbInformation, swMbOk
    Debug.Print "**Macro Finished**"
'End macro
End Sub