Recover value cube visualization

[MLG]

Hello everybody,
Here is the mad questioner again!!
I would like to know if it is possible to retrieve the values of the visualization cube in a macro so that I can assign them to variables?

They are well put in the properties of the part, but in the macro when I put " SW-Total length of the visualization cube" in order to retrieve the value, nothing happens...
Do you have a lead?

And secondly, do you know if it is possible to make a wave of the names of the functions of the tree? Or is it possible to rename functions via a macro?
Thank you very much.

[Maclane]

Hello;

This must be achievable:
https://help.solidworks.com/2022/english/api/sldworksapi/SolidWorks.Interop.sldworks~SolidWorks.Interop.sldworks.IBoundingBoxFeatureData.html

https://help.solidworks.com/2022/English/api/sldworksapi/Get_Part_Bounding_Box_Example_VB.htm?verRedirect=1

Create selectable 3D bounding box sketch using SOLIDWORKS API

Second part, yes it is also possible to rename the functions by Macro:
Example with dictionary use

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2

Sub main()

    Set swApp = Application.SldWorks
    
    Set swModel = swApp.ActiveDoc
    
    Dim passedOrigin As Boolean
    passedOrigin = False
    
    If Not swModel Is Nothing Then
    
        Dim featNamesTable As Object
        Dim processedFeats As Collection
        
        Set featNamesTable = CreateObject("Scripting.Dictionary")
        Set processedFeats = New Collection
        
        featNamesTable.CompareMode = vbTextCompare 'case insensitive
        
        Dim swFeat As SldWorks.Feature
        Set swFeat = swModel.FirstFeature
        
        While Not swFeat Is Nothing
            
            If passedOrigin = 0 Or swFmHoleWzd = 1 Then 'Lister les elements à exclure sous la forme " And InStr(swFeat.Name, "Element a Exclure")"
            
                If Not Contains(processedFeats, swFeat) Then
                    processedFeats.Add swFeat
                    RenameFeature swFeat, featNamesTable
                End If
                
                Dim swSubFeat As SldWorks.Feature
                Set swSubFeat = swFeat.GetFirstSubFeature
                
                While Not swSubFeat Is Nothing
                    
                    If Not Contains(processedFeats, swSubFeat) Then
                        processedFeats.Add swSubFeat
                        RenameFeature swSubFeat, featNamesTable
                    End If
                    
                    Set swSubFeat = swSubFeat.GetNextSubFeature
                    
                Wend
            
            End If
            
            If swFeat.GetTypeName2() = "OriginProfileFeature" Then
                passedOrigin = True
            End If
            
            Set swFeat = swFeat.GetNextFeature
        Wend
        
    Else
        MsgBox "Please open model"
    End If

End Sub

Sub RenameFeature(feat As SldWorks.Feature, featNamesTable As Object)

    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    
    regEx.Global = True
    regEx.IgnoreCase = True
    regEx.Pattern = "(.+?)(\d+)$"
    
    Dim regExMatches As Object
    Set regExMatches = regEx.Execute(feat.Name)
    
    If regExMatches.Count = 1 Then
        
        If regExMatches(0).SubMatches.Count = 2 Then
            
            Dim baseFeatName As String
            baseFeatName = regExMatches(0).SubMatches(0)
            
            Dim nextIndex As Integer
            
            If featNamesTable.Exists(baseFeatName) Then
                nextIndex = featNamesTable.item(baseFeatName) + 1
                featNamesTable.item(baseFeatName) = nextIndex
            Else
                nextIndex = 1
                featNamesTable.Add baseFeatName, nextIndex
            End If
            feat.Name = baseFeatName & nextIndex
        End If
    End If

End Sub

Function Contains(coll As Collection, item As Object) As Boolean
    
    Dim i As Integer
    
    For i = 1 To coll.Count
        If coll.item(i) Is item Then
            Contains = True
            Exit Function
        End If
    Next
    
    Contains = False
    
End Function

Kind regards.

[Joël_1]

Thank you

[MLG]

Hello @Maclane
I tested the macro to rename the functions, it works well, but it's too complex given the diversity of parts we have.

Is it possible to retrieve the name of the second function (FirstFeature for the first one I think)?

That way I could create a variable in order to make a return to the function (swMoveRollbackBarTo).

Here's what I tinkered with for the LENGTH of the Visualization Cube:

Option Explicit

Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Sub main()

Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc
Dim swFeat As Object
Dim swFeatMgr As Object

'Suppression Cube de visualistaion existant (pour MAJ longueur)
Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.EditDelete

'Création Cube de visualisation (permettant d'avoir la longueur du poteau)
Set swFeatMgr = Part.FeatureManager
Dim swFeatData As Object
Set swFeatData = swFeatMgr.CreateDefinition(swFeatureNameID_e.swFmBoundingBox)
swFeatData.IncludeHiddenBodies = False
swFeatData.IncludeSurfaces = False
swFeatData.ReferenceFaceOrPlane = 1
Set swFeat = swFeatMgr.CreateFeature(swFeatData)
Part.ClearSelection2 True
boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
Part.BlankSketch
    
    '''-----------------------------------------------
    
    'Dim swApp                       As SldWorks.SldWorks
    Dim swModel                     As SldWorks.ModelDoc2
    Dim swConfigMgr                 As SldWorks.ConfigurationManager
    Dim swConfig                    As SldWorks.Configuration
    Dim vConfigName                 As Variant
    Dim vConfigNameArr              As Variant
    Dim sSpecConfigNameArr(0)       As String
    Dim vSpecConfigNameArr          As Variant
    Dim dimValue                    As Variant
    Dim stnameConfig                As String
    'Dim boolstatus                  As Boolean
    Dim i                           As Integer
    Dim swErrors                    As Long
    Dim swWarnings                  As Long
    Dim swPart                      As SldWorks.PartDoc
    Dim tConfig()                   As String
    Dim swModelDocExt               As ModelDocExtension
    Dim swCustProp                  As CustomPropertyManager
    Dim sLongueur                      As String
    Dim sCentreMasseY               As String
    Dim sValout                     As String
    Dim sValSurf                    As String
    Dim sValLong                    As String
    Dim bRet                        As String

    '''-----------------------------------------------

   
    'on récupére le document actif
    Set swModel = swApp.ActiveDoc
    Set swConfigMgr = swModel.ConfigurationManager
    
    'on récupére la configuration active
    Set swConfig = swConfigMgr.ActiveConfiguration
    stnameConfig = swConfig.Name
    vConfigNameArr = swModel.GetConfigurationNames
    
    Set swModelDocExt = swModel.Extension
    
    
    '''-----------------------------------------------
   
   'on boucle sur toutes les configurations
    For Each vConfigName In vConfigNameArr
    'on test si la configuration est différente de la configuration active et de la configuration Default
        
    If vConfigName <> swConfig.Name And vConfigName <> "xx" Then
    boolstatus = swModel.DeleteConfiguration2(vConfigName)
        
    End If
        
    If vConfigName <> swConfig.Name And vConfigName <> "Défaut" Then
    boolstatus = swModel.DeleteConfiguration2(vConfigName)
        
    End If
                    
    Next vConfigName
 
    'on reconstruit la pièce
    swModel.ForceRebuild3 False

    'récupère le document actif dans SW
    Set swModel = swApp.ActiveDoc
    If Not swModel Is Nothing Then

    Set swPart = swModel
    
    'Boucle sur toutes les configurations
    tConfig = swModel.GetConfigurationNames
    For i = 0 To UBound(tConfig)
        
    Set swCustProp = swModelDocExt.CustomPropertyManager(tConfig(i))
    
    'Récupération de la propriété de Longueur Cube Visualisation
    bRet = swCustProp.Get6("Longueur totale du cube de visualisation", False, sValout, sLongueur, False, False)
   
    'Renseignement de la propriété LONGUEUR avec la valeur "sVal"
    bRet = swCustProp.Add3("LONGUEUR", 30, sLongueur, 1)
    
    Next i
    
    End If
    
    MsgBox "MAJ LONGUEUR OK"
    
End Sub

It works well, it allows you to update the LENGTH variable when you change the length of your part.

[MLG]

Hello

I've made a lot of progress in my macro. It works well on a part the first time.
But if I restart the macro (change the length of the part to test and even without changing anything) the macro crashes like this:

And debugging gives me this:

I can't understand and therefore correct this problem. Could someone help me?

Here's the full code:

Option Explicit
    Dim swApp                       As SldWorks.SldWorks
    Dim swModel                     As SldWorks.ModelDoc2
    Dim swConfigMgr                 As SldWorks.ConfigurationManager
    Dim swConfig                    As SldWorks.Configuration
    Dim vConfigName                 As Variant
    Dim vConfigNameArr              As Variant
    Dim sSpecConfigNameArr(0)       As String
    Dim vSpecConfigNameArr          As Variant
    Dim dimValue                    As Variant
    Dim Part                        As Object
    Dim stnameConfig                As String
    Dim boolstatus                  As Boolean
    Dim longstatus                  As Long, longwarnings As Long
    Dim i                           As Integer
    Dim swErrors                    As Long
    Dim swWarnings                  As Long
    Dim swPart                      As SldWorks.PartDoc
    Dim tConfig()                   As String
    Dim swModelDocExt               As ModelDocExtension
    Dim swCustProp                  As CustomPropertyManager
    Dim sMasse                      As String
    Dim sValout                     As String
    Dim sValSurf                    As String
    Dim sValLong                    As String
    Dim bRet                        As String
    Dim NamePiece                   As String
    Dim confName                    As String
    Dim confNameF                   As String
    Dim MaterialFilePath            As String
    Dim ConfigNameSuffix            As String
    Dim colorName                    As String
    Dim CodArt                      As String
    Dim CodeArticle                 As String
    Dim sLongueur                   As String
    Dim sCentreMasseY               As String

Type ConfigData
    MaterialFilePath                As String
    ConfigNameSuffix                As String
    colorName                       As String
    confName                        As String
    confNameF                       As String
    NamePiece                       As String
    CodArt                          As String
    CodeArticle                     As String
    
End Type
    Const PROP_RAL                  As String = "RAL"
    Const PROP_CodeArticle          As String = "Code Article"


Sub main()

    Set swApp = Application.SldWorks
    
    Dim swModel As SldWorks.ModelDoc2
    
    ''' Récupération du document actif
    Set swModel = swApp.ActiveDoc
    Set swConfigMgr = swModel.ConfigurationManager
    
    ''' Récupération de la configuration active
    Set swConfig = swConfigMgr.ActiveConfiguration
    stnameConfig = swConfig.Name
    vConfigNameArr = swModel.GetConfigurationNames
    
    Set swModelDocExt = swModel.Extension
    

    Set Part = swApp.ActiveDoc
    Dim swFeat As Object
    Dim swFeatMgr As Object

    ''' Suppression Cube de visualistaion éxistant
    Set Part = swApp.ActiveDoc
    boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
    Part.EditDelete

    ''' Création Cube de visualisation
    Set swFeatMgr = Part.FeatureManager
    Dim swFeatData As Object
    Set swFeatData = swFeatMgr.CreateDefinition(swFeatureNameID_e.swFmBoundingBox)
    swFeatData.IncludeHiddenBodies = False
    swFeatData.IncludeSurfaces = False
    swFeatData.ReferenceFaceOrPlane = 1
    Set swFeat = swFeatMgr.CreateFeature(swFeatData)
    Part.ClearSelection2 True
    boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
    Part.BlankSketch
    
    ''' Réglages Préférences SolidWorks
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinearFractionDenominator, 0, 0)
    boolstatus = swModel.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsLinearFeetAndInchesFormat, 0, False)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinear, 0, swLengthUnit_e.swMM)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinearFractionDenominator, 0, 0)
    boolstatus = swModel.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsDualLinearFeetAndInchesFormat, 0, False)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropMass, 0, swUnitsMassPropMass_e.swUnitsMassPropMass_Kilograms)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropVolume, 0, swUnitsMassPropVolume_e.swUnitsMassPropVolume_Meters3)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinear, 0, swLengthUnit_e.swMM)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropLength, 0, swLengthUnit_e.swMM)

    
    ''' Création Configuration 00 et suppression configurations Défaut, xx, PC
    Set swPart = swModel
    boolstatus = swPart.AddConfiguration2("00", "", "", True, False, False, True, 256)
    boolstatus = swModel.DeleteConfiguration2("Défaut")
    boolstatus = swModel.DeleteConfiguration2("xx")
    boolstatus = swModel.DeleteConfiguration2("PC")
    
    ''' Mise en place du matériaux
    swModel.SetMaterialPropertyName2 "", "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\MATERIAUX\MATERIAUX QUALI-CITE/QUALI-CITE.sldmat", "ALUMINIUM 6060"

    
    ''' Récupération de la variable NomDeFichier sans extension
    NamePiece = GetFileNameWithoutExtension(swModel.GetPathName())

    ''' Création des Configurations 00 et RAL avec ajout des textures RAL MAT
    Dim CONFIGS_DATA(14) As ConfigData

    CONFIGS_DATA(1).colorName = "ALUMINIUM BRUT"
    CONFIGS_DATA(1).ConfigNameSuffix = "00"
    CONFIGS_DATA(1).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\APPARENCES\alu inox.p2m"

    CONFIGS_DATA(2).colorName = "RAL 1013"
    CONFIGS_DATA(2).ConfigNameSuffix = "R1013"
    CONFIGS_DATA(2).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 1013 mat.p2m"

    CONFIGS_DATA(3).colorName = "RAL 1018"
    CONFIGS_DATA(3).ConfigNameSuffix = "R1018"
    CONFIGS_DATA(3).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 1018 mat.p2m"

    CONFIGS_DATA(4).colorName = "RAL 2008"
    CONFIGS_DATA(4).ConfigNameSuffix = "R2008"
    CONFIGS_DATA(4).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 2008 mat.p2m"

    CONFIGS_DATA(5).colorName = "RAL 3000"
    CONFIGS_DATA(5).ConfigNameSuffix = "R3000"
    CONFIGS_DATA(5).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 3000 mat.p2m"

    CONFIGS_DATA(6).colorName = "RAL 3004"
    CONFIGS_DATA(6).ConfigNameSuffix = "R3004"
    CONFIGS_DATA(6).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 3004 mat.p2m"

    CONFIGS_DATA(7).colorName = "RAL 5015"
    CONFIGS_DATA(7).ConfigNameSuffix = "R5015"
    CONFIGS_DATA(7).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 5015 mat.p2m"

    CONFIGS_DATA(8).colorName = "RAL 6005"
    CONFIGS_DATA(8).ConfigNameSuffix = "R6005"
    CONFIGS_DATA(8).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6005 mat.p2m"

    CONFIGS_DATA(9).colorName = "RAL 6018"
    CONFIGS_DATA(9).ConfigNameSuffix = "R6018"
    CONFIGS_DATA(9).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6018 mat.p2m"

    CONFIGS_DATA(10).colorName = "RAL 6029"
    CONFIGS_DATA(10).ConfigNameSuffix = "R6029"
    CONFIGS_DATA(10).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6029 mat.p2m"

    CONFIGS_DATA(11).colorName = "RAL 7016"
    CONFIGS_DATA(11).ConfigNameSuffix = "R7016"
    CONFIGS_DATA(11).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7016 mat.p2m"

    CONFIGS_DATA(12).colorName = "RAL 7035"
    CONFIGS_DATA(12).ConfigNameSuffix = "R7035"
    CONFIGS_DATA(12).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7035 mat.p2m"

    CONFIGS_DATA(13).colorName = "RAL 7037"
    CONFIGS_DATA(13).ConfigNameSuffix = "R7037"
    CONFIGS_DATA(13).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7037 mat.p2m"

    CONFIGS_DATA(14).colorName = "RAL 9005"
    CONFIGS_DATA(14).ConfigNameSuffix = "R9005"
    CONFIGS_DATA(14).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 9005 mat.p2m"

    ''' Ajout de propriétés à toutes les configurations
    
    Dim i As Integer
    
    For i = 0 To UBound(CONFIGS_DATA)
        
        confName = ""

        If CONFIGS_DATA(i).ConfigNameSuffix <> "" Then
            confName = CONFIGS_DATA(i).ConfigNameSuffix
            CodArt = NamePiece & "-" & CONFIGS_DATA(i).ConfigNameSuffix
        End If
        
       
        If i <> 0 Then
            swModel.AddConfiguration3 confName, "", "", 0
            
        ''' Ajout de la propriété "Code Article"
        CodeArticle = CodArt
        bRet = swModel.DeleteCustomInfo2(confName, "Code Article")
        bRet = swModel.AddCustomInfo3(confName, "Code Article", swCustomInfoText, CodeArticle)
            
        ''' Ajout de la propriété "PROFILS"
        bRet = swModel.DeleteCustomInfo2(confName, "DESIGNATION 2")
        bRet = swModel.DeleteCustomInfo2(confName, "PROFILS")
        bRet = swModel.AddCustomInfo3(confName, "PROFILS", swCustomInfoText, "POTEAUXHEXA")
    
        ''' Ajout de la propriété "MASSE" avec la valeur swMasse
        ''' Chr(34) permet d'ajouter le caractère "
        bRet = swModel.DeleteCustomInfo2(confName, "masse")
        bRet = swModel.AddCustomInfo3(confName, "masse", swCustomInfoText, Chr(34) & "SW-Mass" & Chr(34))
    
        ''' Ajout de la propriété "POIDS" avec la valeur swMasse
        ''' Chr(34) permet d'ajouter le caractère "
        bRet = swModel.DeleteCustomInfo2(confName, "POIDS")
        bRet = swModel.AddCustomInfo3(confName, "POIDS", swCustomInfoText, Chr(34) & "SW-Mass" & Chr(34))
    
        ''' ajoute un propriété personnalisée edition avec la valeur MATERIAUX
        ''' Chr(34) permet d'ajouter le caractère "
        bRet = swModel.DeleteCustomInfo2(confName, "MATERIAUX")
        bRet = swModel.AddCustomInfo3(confName, "MATERIAUX", swCustomInfoText, Chr(34) & "SW-Material" & Chr(34))
        
        ''' on reconstruit la pièce
        swModel.ForceRebuild3 False
    
        Set swCustProp = swModelDocExt.CustomPropertyManager(confName)
        
        ''' Récupération de la propriété de Longueur Cube Visualisation
        bRet = swCustProp.Get6("Longueur totale du cube de visualisation", False, sValout, sLongueur, False, False)
   
        ''' Renseignement de la propriété LONGUEUR avec la valeur "sVal"
        bRet = swCustProp.Add3("LONGUEUR", 30, sLongueur, 1)
        
        ''' Renseignement de la propriété DESIGNATION 2 avec la valeur "sVal"
        bRet = swCustProp.Add3("DESIGNATION 2", 30, sLongueur, 1)
        
        ''' on reconstruit la pièce
        swModel.ForceRebuild3 False
    
        ''' Conversion du texte en valeur décimale, multiplication LONGUEUR x RATIO SURFACE et conversion en donné de type texte
        sValSurf = CStr(Format(CDec(sLongueur) * 0.000304, "0.000"))
     
        ''' Renseignement de la propriété SURFACE PIECE avec la valeur "sVal"
        bRet = swCustProp.Add3("SURFACE PIECE", 30, sValSurf, 1)
    
        End If
        
        swModel.ConfigurationManager.ActiveConfiguration.Name = confName
        
                
        If CONFIGS_DATA(i).MaterialFilePath <> "" Then
            AddRenderMaterial swModel, CONFIGS_DATA(i).MaterialFilePath
        End If
        
        AddConfigProperty swModel, CONFIGS_DATA(i).colorName
        
    Next

End Sub

Sub AddRenderMaterial(model As SldWorks.ModelDoc2, path As String)
    
    Dim swRenderMaterial As SldWorks.RenderMaterial
    Set swRenderMaterial = model.Extension.CreateRenderMaterial(path)
    
    If False <> swRenderMaterial.AddEntity(model) Then
        If False = model.Extension.AddDisplayStateSpecificRenderMaterial(swRenderMaterial, swDisplayStateOpts_e.swThisDisplayState, Empty, -1, -1) Then
            Err.Raise vbError, "", "Failed to apply render material to display state"
        End If
    Else
        Err.Raise vbError, "", "Failed to add model as entity to render material"
    End If
   
End Sub

''' Attribution Propriété "RAL"

Sub AddConfigProperty(model As SldWorks.ModelDoc2, colorName As String)

   
    Dim swCustPrpMgr As SldWorks.CustomPropertyManager
    
    Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
    
    Dim propRal As String

    
    swCustPrpMgr.Get4 PROP_RAL, False, "", propRal

    
    Set swCustPrpMgr = model.ConfigurationManager.ActiveConfiguration.CustomPropertyManager
    
    swCustPrpMgr.Add3 PROP_RAL, swCustomInfoType_e.swCustomInfoText, propRal & colorName, swCustomPropertyAddOption_e.swCustomPropertyReplaceValue

End Sub

Function GetFileNameWithoutExtension(filePath As String) As String
    GetFileNameWithoutExtension = Mid(filePath, InStrRev(filePath, "\") + 1, InStrRev(filePath, ".") - InStrRev(filePath, "\") - 1)
           
End Function

Thanks in advance

[sbadenis]

Runs the macro in edit mode and step by step and looks at the values of the different variables used in this line (in error) if one is empty or non-numeric, possible that it is related.
To do this, add a debug.print sLength, another with debug.print Format(Cdec...) for example to see if it works well or not.
No time to look precisely at your macro.
The step by step mode allows and the addition of debug.print allows at the beginning to see the state of the different variables in the execution window (otherwise see the Local Variables window) but less practical for me.

[MLG]

Thank you @sbadenis
I tried but I can't visualize where this problem comes from.
Should we add a RAZ of the values at the beginning of the macro (if it exists)? I have the impression that once it's filled in, the macro freezes

[sbadenis]

Your problem is that your properties of the visualization cube are created in the R9005 config:

Except for one of a 2nd launch it reviews the configs and starts with the 00 out of the property not existing in this config:

So no value found, no value reported in sLength and macro error.
Solution 1: write the properties of the bounding box in each config.
Solution 2 if the dimensions of the bounding box are identical in each config, write them 1 time in the custom tab and no matter the config by going to look for them in this tab they will be identical. (Be careful, only the props of the bounding box, the others must remain in the Configuration-specific)

To see that your value is empty with the step mode, when you have passed the line, you hover the mouse over the variable sLength and you see that it is equal to nothing:

[sbadenis]

Simpler you create your bounding box after cleaning your config and there it works:

Option Explicit
    Dim swApp                       As SldWorks.SldWorks
    Dim swModel                     As SldWorks.ModelDoc2
    Dim swConfigMgr                 As SldWorks.ConfigurationManager
    Dim swConfig                    As SldWorks.Configuration
    Dim vConfigName                 As Variant
    Dim vConfigNameArr              As Variant
    Dim sSpecConfigNameArr(0)       As String
    Dim vSpecConfigNameArr          As Variant
    Dim dimValue                    As Variant
    Dim Part                        As Object
    Dim stnameConfig                As String
    Dim boolstatus                  As Boolean
    Dim longstatus                  As Long, longwarnings As Long
    Dim i                           As Integer
    Dim swErrors                    As Long
    Dim swWarnings                  As Long
    Dim swPart                      As SldWorks.PartDoc
    Dim tConfig()                   As String
    Dim swModelDocExt               As ModelDocExtension
    Dim swCustProp                  As CustomPropertyManager
    Dim sMasse                      As String
    Dim sValout                     As String
    Dim sValSurf                    As String
    Dim sValLong                    As String
    Dim bRet                        As String
    Dim NamePiece                   As String
    Dim confName                    As String
    Dim confNameF                   As String
    Dim MaterialFilePath            As String
    Dim ConfigNameSuffix            As String
    Dim colorName                    As String
    Dim CodArt                      As String
    Dim CodeArticle                 As String
    Dim sLongueur                   As String
    Dim sCentreMasseY               As String

Type ConfigData
    MaterialFilePath                As String
    ConfigNameSuffix                As String
    colorName                       As String
    confName                        As String
    confNameF                       As String
    NamePiece                       As String
    CodArt                          As String
    CodeArticle                     As String
    
End Type
    Const PROP_RAL                  As String = "RAL"
    Const PROP_CodeArticle          As String = "Code Article"


Sub main()

    Set swApp = Application.SldWorks
    
    Dim swModel As SldWorks.ModelDoc2
    
    ''' Récupération du document actif
    Set swModel = swApp.ActiveDoc
    Set swConfigMgr = swModel.ConfigurationManager
    
    ''' Récupération de la configuration active
    Set swConfig = swConfigMgr.ActiveConfiguration
    stnameConfig = swConfig.Name
    vConfigNameArr = swModel.GetConfigurationNames
    
    Set swModelDocExt = swModel.Extension
    

    Set Part = swApp.ActiveDoc
    Dim swFeat As Object
    Dim swFeatMgr As Object



    
    ''' Création Configuration 00 et suppression configurations Défaut, xx, PC
    Set swPart = swModel
    boolstatus = swPart.AddConfiguration2("00", "", "", True, False, False, True, 256)
    boolstatus = swModel.DeleteConfiguration2("Défaut")
    boolstatus = swModel.DeleteConfiguration2("xx")
    boolstatus = swModel.DeleteConfiguration2("PC")
    
    
    
    ''' Suppression Cube de visualistaion éxistant
    Set Part = swApp.ActiveDoc
    boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
    boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
    Part.EditDelete

    ''' Création Cube de visualisation
    Set swFeatMgr = Part.FeatureManager
    Dim swFeatData As Object
    Set swFeatData = swFeatMgr.CreateDefinition(swFeatureNameID_e.swFmBoundingBox)
    swFeatData.IncludeHiddenBodies = False
    swFeatData.IncludeSurfaces = False
    swFeatData.ReferenceFaceOrPlane = 1
    Set swFeat = swFeatMgr.CreateFeature(swFeatData)
    Part.ClearSelection2 True
    boolstatus = Part.Extension.SelectByID2("Cube de visualisation", "BBOXSKETCH", 0, 0, 0, False, 0, Nothing, 0)
    Part.BlankSketch
    
    ''' Réglages Préférences SolidWorks
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinearFractionDenominator, 0, 0)
    boolstatus = swModel.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsLinearFeetAndInchesFormat, 0, False)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinear, 0, swLengthUnit_e.swMM)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinearFractionDenominator, 0, 0)
    boolstatus = swModel.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsDualLinearFeetAndInchesFormat, 0, False)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropMass, 0, swUnitsMassPropMass_e.swUnitsMassPropMass_Kilograms)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropVolume, 0, swUnitsMassPropVolume_e.swUnitsMassPropVolume_Meters3)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinear, 0, swLengthUnit_e.swMM)
    boolstatus = swModel.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropLength, 0, swLengthUnit_e.swMM)
    
    
    
    ''' Mise en place du matériaux
    swModel.SetMaterialPropertyName2 "", "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\MATERIAUX\MATERIAUX QUALI-CITE/QUALI-CITE.sldmat", "ALUMINIUM 6060"

    
    ''' Récupération de la variable NomDeFichier sans extension
    NamePiece = GetFileNameWithoutExtension(swModel.GetPathName())

    ''' Création des Configurations 00 et RAL avec ajout des textures RAL MAT
    Dim CONFIGS_DATA(14) As ConfigData

    CONFIGS_DATA(1).colorName = "ALUMINIUM BRUT"
    CONFIGS_DATA(1).ConfigNameSuffix = "00"
    CONFIGS_DATA(1).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\APPARENCES\alu inox.p2m"

    CONFIGS_DATA(2).colorName = "RAL 1013"
    CONFIGS_DATA(2).ConfigNameSuffix = "R1013"
    CONFIGS_DATA(2).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 1013 mat.p2m"

    CONFIGS_DATA(3).colorName = "RAL 1018"
    CONFIGS_DATA(3).ConfigNameSuffix = "R1018"
    CONFIGS_DATA(3).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 1018 mat.p2m"

    CONFIGS_DATA(4).colorName = "RAL 2008"
    CONFIGS_DATA(4).ConfigNameSuffix = "R2008"
    CONFIGS_DATA(4).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 2008 mat.p2m"

    CONFIGS_DATA(5).colorName = "RAL 3000"
    CONFIGS_DATA(5).ConfigNameSuffix = "R3000"
    CONFIGS_DATA(5).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 3000 mat.p2m"

    CONFIGS_DATA(6).colorName = "RAL 3004"
    CONFIGS_DATA(6).ConfigNameSuffix = "R3004"
    CONFIGS_DATA(6).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 3004 mat.p2m"

    CONFIGS_DATA(7).colorName = "RAL 5015"
    CONFIGS_DATA(7).ConfigNameSuffix = "R5015"
    CONFIGS_DATA(7).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 5015 mat.p2m"

    CONFIGS_DATA(8).colorName = "RAL 6005"
    CONFIGS_DATA(8).ConfigNameSuffix = "R6005"
    CONFIGS_DATA(8).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6005 mat.p2m"

    CONFIGS_DATA(9).colorName = "RAL 6018"
    CONFIGS_DATA(9).ConfigNameSuffix = "R6018"
    CONFIGS_DATA(9).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6018 mat.p2m"

    CONFIGS_DATA(10).colorName = "RAL 6029"
    CONFIGS_DATA(10).ConfigNameSuffix = "R6029"
    CONFIGS_DATA(10).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 6029 mat.p2m"

    CONFIGS_DATA(11).colorName = "RAL 7016"
    CONFIGS_DATA(11).ConfigNameSuffix = "R7016"
    CONFIGS_DATA(11).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7016 mat.p2m"

    CONFIGS_DATA(12).colorName = "RAL 7035"
    CONFIGS_DATA(12).ConfigNameSuffix = "R7035"
    CONFIGS_DATA(12).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7035 mat.p2m"

    CONFIGS_DATA(13).colorName = "RAL 7037"
    CONFIGS_DATA(13).ConfigNameSuffix = "R7037"
    CONFIGS_DATA(13).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 7037 mat.p2m"

    CONFIGS_DATA(14).colorName = "RAL 9005"
    CONFIGS_DATA(14).ConfigNameSuffix = "R9005"
    CONFIGS_DATA(14).MaterialFilePath = "X:\DONNEES BE\DAO\BUREAU ETUDES\BIBLI SOLIDWORKS\PEINTURE RAL\PE-TEXTURÉE\ral 9005 mat.p2m"

    ''' Ajout de propriétés à toutes les configurations
    
    Dim i As Integer
    
    For i = 0 To UBound(CONFIGS_DATA)
        
        confName = ""

        If CONFIGS_DATA(i).ConfigNameSuffix <> "" Then
            confName = CONFIGS_DATA(i).ConfigNameSuffix
            CodArt = NamePiece & "-" & CONFIGS_DATA(i).ConfigNameSuffix
        End If
        
       
        If i <> 0 Then
            swModel.AddConfiguration3 confName, "", "", 0
            
        ''' Ajout de la propriété "Code Article"
        CodeArticle = CodArt
        bRet = swModel.DeleteCustomInfo2(confName, "Code Article")
        bRet = swModel.AddCustomInfo3(confName, "Code Article", swCustomInfoText, CodeArticle)
            
        ''' Ajout de la propriété "PROFILS"
        bRet = swModel.DeleteCustomInfo2(confName, "DESIGNATION 2")
        bRet = swModel.DeleteCustomInfo2(confName, "PROFILS")
        bRet = swModel.AddCustomInfo3(confName, "PROFILS", swCustomInfoText, "POTEAUXHEXA")
    
        ''' Ajout de la propriété "MASSE" avec la valeur swMasse
        ''' Chr(34) permet d'ajouter le caractère "
        bRet = swModel.DeleteCustomInfo2(confName, "masse")
        bRet = swModel.AddCustomInfo3(confName, "masse", swCustomInfoText, Chr(34) & "SW-Mass" & Chr(34))
    
        ''' Ajout de la propriété "POIDS" avec la valeur swMasse
        ''' Chr(34) permet d'ajouter le caractère "
        bRet = swModel.DeleteCustomInfo2(confName, "POIDS")
        bRet = swModel.AddCustomInfo3(confName, "POIDS", swCustomInfoText, Chr(34) & "SW-Mass" & Chr(34))
    
        ''' ajoute un propriété personnalisée edition avec la valeur MATERIAUX
        ''' Chr(34) permet d'ajouter le caractère "
        bRet = swModel.DeleteCustomInfo2(confName, "MATERIAUX")
        bRet = swModel.AddCustomInfo3(confName, "MATERIAUX", swCustomInfoText, Chr(34) & "SW-Material" & Chr(34))
        
        ''' on reconstruit la pièce
        swModel.ForceRebuild3 False
    
        Set swCustProp = swModelDocExt.CustomPropertyManager(confName)
        
        ''' Récupération de la propriété de Longueur Cube Visualisation
        bRet = swCustProp.Get6("Longueur totale du cube de visualisation", False, sValout, sLongueur, False, False)
   
        ''' Renseignement de la propriété LONGUEUR avec la valeur "sVal"
        bRet = swCustProp.Add3("LONGUEUR", 30, sLongueur, 1)
        
        ''' Renseignement de la propriété DESIGNATION 2 avec la valeur "sVal"
        bRet = swCustProp.Add3("DESIGNATION 2", 30, sLongueur, 1)
        
        ''' on reconstruit la pièce
        swModel.ForceRebuild3 False
    
        ''' Conversion du texte en valeur décimale, multiplication LONGUEUR x RATIO SURFACE et conversion en donné de type texte
        sValSurf = CStr(Format(CDec(sLongueur) * 0.000304, "0.000"))
     
        ''' Renseignement de la propriété SURFACE PIECE avec la valeur "sVal"
        bRet = swCustProp.Add3("SURFACE PIECE", 30, sValSurf, 1)
    
        End If
        
        swModel.ConfigurationManager.ActiveConfiguration.Name = confName
        
                
        If CONFIGS_DATA(i).MaterialFilePath <> "" Then
            AddRenderMaterial swModel, CONFIGS_DATA(i).MaterialFilePath
        End If
        
        AddConfigProperty swModel, CONFIGS_DATA(i).colorName
        
    Next

End Sub

Sub AddRenderMaterial(model As SldWorks.ModelDoc2, path As String)
    
    Dim swRenderMaterial As SldWorks.RenderMaterial
    Set swRenderMaterial = model.Extension.CreateRenderMaterial(path)
    
    If False <> swRenderMaterial.AddEntity(model) Then
        If False = model.Extension.AddDisplayStateSpecificRenderMaterial(swRenderMaterial, swDisplayStateOpts_e.swThisDisplayState, Empty, -1, -1) Then
            Err.Raise vbError, "", "Failed to apply render material to display state"
        End If
    Else
        Err.Raise vbError, "", "Failed to add model as entity to render material"
    End If
   
End Sub

''' Attribution Propriété "RAL"

Sub AddConfigProperty(model As SldWorks.ModelDoc2, colorName As String)

   
    Dim swCustPrpMgr As SldWorks.CustomPropertyManager
    
    Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
    
    Dim propRal As String

    
    swCustPrpMgr.Get4 PROP_RAL, False, "", propRal

    
    Set swCustPrpMgr = model.ConfigurationManager.ActiveConfiguration.CustomPropertyManager
    
    swCustPrpMgr.Add3 PROP_RAL, swCustomInfoType_e.swCustomInfoText, propRal & colorName, swCustomPropertyAddOption_e.swCustomPropertyReplaceValue

End Sub

Function GetFileNameWithoutExtension(filePath As String) As String
    GetFileNameWithoutExtension = Mid(filePath, InStrRev(filePath, "\") + 1, InStrRev(filePath, ".") - InStrRev(filePath, "\") - 1)
           
End Function

[MLG]

Thanks @sbadenis , I tested the code with the cube after cleaning up the configs but I still have error 13 on this line:

        ''' Conversion du texte en valeur décimale, multiplication LONGUEUR x RATIO SURFACE et conversion en donné de type texte
        sValSurf = CStr(Format(CDec(sLongueur) * 0.000304, "0.000"))

And I have the cube which is in deleted mode in the tree, so the macro is blocking because it doesn't recover the length

[sbadenis]

With the part I had, it worked.
Maybe your config was already created before in this case when scrolling through each config you would have to cancel the deletion of the visualization cube
Otherwise provide a part or it doesn't work (part made for the example if confidentiality) for my part I'm in sw2020. (with access to 1 SW223)

[MLG]

I tested with and without the deletion of the cube but I have the same error coming back.

Shouldn't we put the deletion of the vusualization cube at the end of the macro. Once the properties are filled in, there is no longer necessarily a need for them?

But I have a hard time knowing where I have to wedge this for it to happen in the end...

Attached is the piece made on SW 2022.
After that, it's just a basic extrusion... But I would like that by changing the length, we can update the properties by running the same macro again
TEST PIECE. SLDPRT (161.7 KB)

[sbadenis]

The reason is that in the configuration options you have this checkmark:

When you launch the macro from a config other than the 00
It creates the cube for you in the active config for example R9005.
So the cube is in the deleted state in all the other configs.
And since you never delete the 00 it remains in the deleted state.
One way to overcome this problem is to make config 00 active right after the creation of config 00 and the deletion of the other configs.
Add the last 2 lines below in the same place in your code and it should be good.

    ''' Création Configuration 00 et suppression configurations Défaut, xx, PC
    Set swPart = swModel
    boolstatus = swPart.AddConfiguration2("00", "", "", True, False, False, True, 256)
    boolstatus = swModel.DeleteConfiguration2("Défaut")
    boolstatus = swModel.DeleteConfiguration2("xx")
    boolstatus = swModel.DeleteConfiguration2("PC")
    'On active la config 00
    boolstatus = swModel.ShowConfiguration2("00")

[MLG]

Thank you @sbadenis !!
I even went further, because the sketch of the visualization cube was still visible when I restarted the macro.
So I added the deletion of the RAL configs at the beginning of the macro. Like cal, everything starts from scratch and it works .

    ''' Création Configuration 00 et suppression configurations Défaut, xx, PC
    Set swPart = swModel
    boolstatus = swPart.AddConfiguration2("00", "", "", True, False, False, True, 256)
    boolstatus = swModel.DeleteConfiguration2("Défaut")
    boolstatus = swModel.DeleteConfiguration2("xx")
    boolstatus = swModel.DeleteConfiguration2("PC")
    
    ''' Activation de la config 00
    boolstatus = swModel.ShowConfiguration2("00")
    
    ''' Suppression des configurations RAL
    boolstatus = swModel.DeleteConfiguration2("R1013")
    boolstatus = swModel.DeleteConfiguration2("R1018")
    boolstatus = swModel.DeleteConfiguration2("R2008")
    boolstatus = swModel.DeleteConfiguration2("R3000")
    boolstatus = swModel.DeleteConfiguration2("R3004")
    boolstatus = swModel.DeleteConfiguration2("R5015")
    boolstatus = swModel.DeleteConfiguration2("R6005")
    boolstatus = swModel.DeleteConfiguration2("R6018")
    boolstatus = swModel.DeleteConfiguration2("R6029")
    boolstatus = swModel.DeleteConfiguration2("R7016")
    boolstatus = swModel.DeleteConfiguration2("R7035")
    boolstatus = swModel.DeleteConfiguration2("R7037")
    boolstatus = swModel.DeleteConfiguration2("R9005")

[MLG]

Finally, is it possible to change the depth of a material removal via a macro?

I did the manipulation by recording the macro, but the code does not contain depth:

Option Explicit

Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Sub main()

Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc
boolstatus = Part.Extension.SelectByID2("Face gauche", "BODYFEATURE", 0, 0, 0, False, 0, Nothing, 0)
Part.ClearSelection2 True
Part.SelectionManager.EnableContourSelection = False
End Sub

[Cyril.f]

Hello

You have to look in the FeatureCut functions
FeatureCut4 Method (IFeatureManager) - 2022 - SOLIDWORKS API Help

[MLG]

Thank you @Cyril.f

With the FeatureCut4 function I can create material removals from a sketch, but I can't change the depth of an existing feature
Is this possible?

[Cyril.f]

Hello
To tell the truth, joker. It is possible that on older files the function does not allow access to options that may not have existed on these older versions.