7 Replies Latest reply on Dec 24, 2015 9:29 AM by Mikael Bolduc

    Custom property don't save in each part

    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
              Wend
             
              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
          Wend
      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
      End1:

      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**"
              End
          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
          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
      End Sub