Configuratie verwijderen

Macro
1

Hallo
Ik ben op zoek naar een VBA-code om alle configuraties uit een kamer te verwijderen, behalve de actieve configuratie.
Of verwijder alle configuraties behalve mijn "ConfigName" variabele die al in mijn code zit.

2

Hallo;

Ik heb een macro gemaakt die je zou moeten interesseren:

  • Het verwijdert alle configuraties om alleen de actieve te houden.
  • Het "verplaatst" eigenschappen van "Configuratiespecifiek" naar "Aangepaste eigenschappen"...
Option Explicit

Sub Delet_ConfigS()
    
    Dim swApp               As SldWorks.SldWorks
    Dim swModel             As SldWorks.ModelDoc2
    Dim swModelDocExt       As SldWorks.ModelDocExtension
    Dim status              As Boolean
    Dim swConfigMgr         As SldWorks.ConfigurationManager
    Dim swConfig            As SldWorks.Configuration
    Dim vConfigName         As Variant
    Dim vConfigNameArr      As Variant
    Dim ActivConfig         As String
    Dim FilePath            As String
    
    'On Supprime toutes les configurations sauf la config Active

    Set swApp = Application.SldWorks
    'on récupére le document actif
    Set swModel = swApp.ActiveDoc
    FilePath = swModel.GetPathName
    
    If Not UCase(FilePath) Like "*BIBLIOTHEQUE_*" Or UCase(FilePath) Like "*AFFAIRES_*" Then
    
        Set swConfigMgr = swModel.ConfigurationManager
        'on récupére la configuration active
        Set swConfig = swConfigMgr.ActiveConfiguration

        ActivConfig = swConfig.Name              'on récupére de nom de la configation active

        vConfigNameArr = swModel.GetConfigurationNames 'on récupére le nom de toutes les configurations

        For Each vConfigName In vConfigNameArr   'on boucle sur toutes les configurations

            If Not vConfigName Like ActivConfig Then 'on saute la configuration Active
                swModel.DeleteConfiguration2 (vConfigName) ' on supprime la configuration non Active
        
            Else
            End If
        Next vConfigName
    
        Dim boolstatus As Variant
        boolstatus = swModel.EditConfiguration3(ActivConfig, ActivConfig, "", "", 36) 'On change le Nom de la configuration qui sera utilisé dans les Nomenclatures = Nom du Document
    
        ' On Supprime la tables des configurations si elle existe
        Set swModelDocExt = swModel.Extension
    
        status = swModelDocExt.HasDesignTable    'True Si le document à une Table de Config Sinon=False
        If status Then
            swModel.DeleteDesignTable
        Else
        End If
        
        'on affiche la configuration active avant le traitement
        swModel.ShowConfiguration2 ActivConfig
    
        Call SetPropToDocument

        'on force la reconstruction
        swModel.ForceRebuild3 False

    Else

        MsgBox ("Que Nenni !" & Chr(10) & "Vous ne devez pas utiliser cette macro sur les Fichiers en Bibliotheques...."), vbOKOnly + vbExclamation, "Emplacement Fichier."

    End If

End Sub

Sub SetPropToDocument()

    Dim swApp As SldWorks.SldWorks
    Dim swModel As ModelDoc2
    Dim sConfigName  As String
    Dim CustomProp As CustomPropertyManager
    Dim CustomPropName() As String
    Dim i As Long
    Dim j As Long
    Dim Propname As Variant
    Dim Proptype As Variant
    Dim Propvalue As Variant
    Dim vConfNameArr As Variant


    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If (swModel.GetType = swDocDRAWING) Then     'On ne travaille pas sur une Mise en plan...
    Else
    
        vConfNameArr = swModel.GetConfigurationNames 'On recupere le Nom de toutes les configurations

        For i = 0 To UBound(vConfNameArr)
            sConfigName = vConfNameArr(i)
            Set CustomProp = swModel.Extension.CustomPropertyManager(i)

            ' ************** COUPE ET COLLE LES PROPRIETES DES CONFIG VERS PROPRIETES DU DOCUMENT ***************************************

            'Copy the configuration specific properties from the Custom properties
            Set CustomProp = swModel.Extension.CustomPropertyManager(sConfigName)
            
            If IsEmpty(CustomProp.GetNames) = False Then
            
                CustomPropName = CustomProp.GetNames
                Dim NumProps As Variant
                NumProps = CustomProp.GetAll(Propname, Proptype, Propvalue)
                For j = 0 To UBound(CustomPropName)
                
                    Dim NewPropOk As Variant
                    NewPropOk = swModel.AddCustomInfo3("", Propname(j), Proptype(j), Propvalue(j)) 'Copie des propriétes de la configuration vres le Document
                    swModel.DeleteCustomInfo2 sConfigName, CustomPropName(j)
                Next j
            Else

            End If
        Next i
    
    End If

    Erase CustomPropName
    Erase vConfNameArr
    Erase CustomPropName
    'Erase Propname
    'Erase Proptype
    'Erase Propvalue

    '************************************************************************************************************************************************
    'On supprime les vues Enregistrées

    Dim vModelViewNames         As Variant
    vModelViewNames = swModel.GetModelViewNames

    For i = 0 To UBound(vModelViewNames)

        If i > 9 Then                            'Solidworks : Les vues personnelles sont toujour enregistrée avec un numero supperieur à 9 (de "0" à "9" se sont les vues "Standard"
            Debug.Print vModelViewNames(i)
            swModel.DeleteNamedView (vModelViewNames(i))
        End If
    Next i
    '*************************************************************************************************************************************************

End Sub

…
Wees voorzichtig met de bestelling:
Als het niet UCase(FilePath) is zoals "BIBLIOTHEQUE_" of UCase(FilePath) zoals "AFFAIRES_", dan

Het is een beveiliging die ik had ingesteld om de werking van deze macro te voorkomen, afhankelijk van de locatie van het te verwerken bestand... (Aan te passen aan uw behoeften)

Vriendelijke groeten.

3 likes
3

perfect, het is precies wat ik wilde, heel erg bedankt

1 like