Macro ouverture plan suivant config

Sans catégorie
1

Bonjour, 

Nouvelle question, je souhaiterais automatiser ma création de plan. Je m'explique, j'ai un part avec, admettons, 15 configs différentes. J'aimerais faire une macro pour ouvrir un drawing avec une feuille par configuration en la nommant du non de la config idéalement. J'ai une petite idée du code mais je ne connais pas les fonctions pour l'ouverture d'un plan et la création des nouvelles feuilles.

Voici un bout de mon code pour boucler les différentes configs :

 ConfCount = UBound(vConfigNameArr)

    If ConfCount = 0 Then Exit Sub

    If ConfCount > 0 Then
       
       i = 1
        'on boucle
        For Each vConfigName In vConfigNameArr
                      
            'on affiche la configuration
            swModel.ShowConfiguration2 vConfigName
        
            swModel.ShowNamedView2 "*Isometric", -1
            swModel.ViewZoomtofit2
        
            'on force la reconstruction
            swModel.ForceRebuild3 False

            'on ouvre un nouveau drawing 

            'on créé les nouvelles feuilles

Voilà si quelqu'un a une idée je suis tout ouïe.

Cordialement

 

Edit : Je cherche à faire un copier coller, je fais mon premier plan et après je lance la macro pour copier/coller ma première feuille autant de fois que le nombre de config. En nommant les feuilles au nom de la config.

2

Pour créer une nouvelle feuille j'ai ce bout de code:

(swmodel.getpathname doit bien entendu pointer vers ton modèle de pièce ou d'assemblage configurée)

                
Set swDraw = swApp.NewDocument(sDrTemplateLaser, 0, 0, 0)
Dim swSheet  As SldWorks.Sheet
Set swSheet = swDraw.GetCurrentSheet
bRet = swSheet.SetScale(1, 1, True, False)
Debug.Print "Modèle:" & swModel.GetPathName
Set swView = swDraw.CreateFlatPatternViewFromModelView3(swModel.GetPathName, "", 0.105, 0.184, 0#, False, False)
Dim swDrawModel As SldWorks.ModelDoc2
Set swDrawModel = swDraw
swDrawModel.ForceRebuild3 False
swDrawModel.Extension.SaveAs file, swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, 0, 0

Sinon pour copier une feuille et la renommer puis changer les références (configurations) j'ai ce bout de code (il va falloir faire du tir mais pas trop le temps de le faire)

Option Explicit

Const suffixFeuille As String = "-SYM"
Const suffixNomFichier As String = "-SYM"

Dim swApp               As SldWorks.SldWorks
Dim swDraw              As DrawingDoc
Dim swModel             As ModelDoc2
Dim swModel2            As ModelDoc2
Dim bRet                As Boolean
Dim swView              As SldWorks.View
Dim swRefModel          As SldWorks.ModelDoc2
Dim longstatus          As Long
Dim longwarnings        As Long


Sub copyDrawingSheetSYM()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swDraw = swModel


If (swDraw Is Nothing) Then
    MsgBox "ouvrir une MEP"
    End
End If
Dim sheetCount As Integer
sheetCount = swDraw.GetSheetCount
Dim vSheetName As Variant
'vSheet = swDraw.GetSheetNames
Dim sheetName As String
Dim i As Integer

'1-) PARTIE SUPPRESSION FEUILLES SYM EXISTANTE
Debug.Print "1-) PARTIE SUPPRESSION FEUILLES SYM EXISTANTE"
Dim selection As Boolean
selection = False
'swModel.Extension.ClearSelection2 False
vSheetName = swDraw.GetSheetNames
'On boucle sur les feuilles
For i = 0 To UBound(vSheetName)
        sheetName = vSheetName(i)
        'Debug.Print "Nom de feuille:" & sheetName
        If sheetName Like "*" & suffixFeuille & "*" Then
            'Debug.Print "On entre dans la partie suppression"
            selection = True
            'Sélection des feuilles Sym
            bRet = swModel.Extension.SelectByID2(sheetName, "SHEET", 0, 0, 0, True, 0, Nothing, 0)
        End If
Next i


If selection = True Then
    'On demande si on supprime la feuille
    If MsgBox("Voulez vous supprimer les feuilles Sym?", vbYesNo + vbDefaultButton1, "Basculer la vue de découpe?") = vbYes Then 'Si le bouton Oui est cliqué
        'Suppression des feuilles
        bRet = swModel.Extension.DeleteSelection2(0)
        'Debug.Print "Feuilles supprimées"
    Else
        MsgBox "On quitte la macro"
        Exit Sub
    End If
End If



'2-) PARTIE CREATION FEUILLES SYM
Debug.Print "2-) PARTIE CREATION FEUILLES SYM"
sheetCount = swDraw.GetSheetCount
vSheetName = swDraw.GetSheetNames
'On boucle sur les feuilles
For i = 1 To sheetCount
       sheetName = vSheetName(i - 1)
        'Debug.Print "Nom de feuille:" & sheetName
       
        If i = 1 Then
            Set swView = swDraw.GetFirstView().GetNextView
            Set swRefModel = swView.ReferencedDocument
            Dim sModelName  As String
            sModelName = swView.GetReferencedModelName
            Debug.Print "File                      = " & swModel.GetPathName
            Debug.Print "  View                    = " & swView.Name
            Debug.Print "    Referenced model name = " & sModelName
            Debug.Print "    Model path            = " & swDraw.GetPathName
            Dim vConfs As Variant
            vConfs = swRefModel.GetConfigurationNames
            Dim confSymName As String
            confSymName = ""
            Dim j As Integer
            'On boucle sur les config
            For j = 0 To UBound(vConfs)
                Dim confName As String
                confName = vConfs(j)
                If confName Like "*Sym*" And Not confName Like "*Sym*Sym*" Then
                confSymName = confName
                Dim saveJ As String
                saveJ = j
                End If
                
                'Debug.Print confName
                swModel.ForceRebuild3 False
            Next j
            
        End If
        If confSymName <> "" Then
            'On lance la macro pour ajouter le suffix au model auquel la MEP fait référence
            'On active le model
            Debug.Print sModelName
            Set swModel2 = swApp.OpenDoc6(sModelName, 3, 0, "", longstatus, longwarnings)
            'ici rendre le model actif
            Set swModel2 = swApp.ActivateDoc3(sModelName, swRebuildOnActivation_e.swDontRebuildActiveDoc = 1, 0, 0)
            
            
            'On lance le code pour modifier la propriété du modèle référencé
            zSmartCat_SYM1.smartCat_SYM
            
            'On active la mise en plan
            Set swModel = swApp.OpenDoc6(swDraw.GetPathName, 3, 0, "", longstatus, longwarnings)
            Set swModel = swApp.ActivateDoc3(swDraw.GetPathName, swRebuildOnActivation_e.swDontRebuildActiveDoc = 1, 0, 0)
            'Set swDraw = swModel
            swDraw.ActivateSheet sheetName
            'Debug.Print "Feuille active:" & sheetName
            bRet = swDraw.Extension.SelectByID2(sheetName, "SHEET", 0, 0, 0, False, 0, Nothing, 0)
            swModel.EditCopy
            bRet = swDraw.PasteSheet(swInsertOption_AfterSelectedSheet, swRenameOption_No)
            swDraw.GetCurrentSheet.SetName sheetName & suffixFeuille
            
            'On parcourt toute les vue de la feuille et on change la config
            Set swView = swDraw.GetFirstView.GetNextView
            Do While Not swView Is Nothing
                'Debug.Print "  Drawing view = " + swView.Name
                'Debug.Print "    Referenced model name = " & swView.GetReferencedModelName
                'Debug.Print "    Referenced configuration name = " & swView.ReferencedConfiguration
                'Debug.Print "    Referenced configuration persistent reference ID = " & swView.ReferencedConfigurationID
                
                'Changement de configuration (Symétrique) si la vue d'est pas une vue déplié (Flat-Pattern)
                If Not swView.ReferencedConfiguration Like "*PATTERN*" Then
                    'Debug.Print "On change la config"
                    swView.ReferencedConfiguration = vConfs(saveJ)
                Else
                    'On retourne la vue
                    'Debug.Print "On retourne la vue"
                    swView.FlipView = True
                End If
                'Get next drawing view
                Set swView = swView.GetNextView
            Loop
        End If
Next

'3-) PARTIE CREATION ANNOTATION AJOUT DU SUFFIX NOM DE FICHIER POUR SYM
Debug.Print "3-) PARTIE CREATION FEUILLES SYM"

sheetCount = swDraw.GetSheetCount
vSheetName = swDraw.GetSheetNames
'On boucle sur les feuilles
For i = 1 To sheetCount
       sheetName = vSheetName(i - 1)
       Debug.Print i & "-Nom de feuille:" & sheetName
       If sheetName Like "*" & suffixFeuille & "*" Then
         swDraw.ActivateSheet sheetName
             Set swView = swDraw.GetFirstView()
             'On boucle sur les notes
             Dim swNote          As Note
             Dim swAnn           As SldWorks.Annotation
             Dim sValue          As String
             Set swNote = swView.GetFirstNote
                 swModel.ClearSelection2 (True)
                 Do While Not swNote Is Nothing
                     Set swAnn = swNote.GetAnnotation
                     sValue = "$PRP:""SW-Nom de fichier(File Name)""" 'Mettre le nom de la propriété recherchée
                     Debug.Print swNote.PropertyLinkedText
                     If swNote.PropertyLinkedText = sValue Then
                             Debug.Print "Propriété trouvé"
                             swNote.PropertyLinkedText = sValue & suffixNomFichier
                             Exit Do
                     End If
                     swModel.ClearSelection2 (True)
                     Set swNote = swNote.GetNext
                 Loop
        End If
Next i
zBomMaterials.bomMaterials
'swModel.EditRebuild3
'swModel.Save

Set swApp = Nothing
Set swModel = Nothing
Set swDraw = Nothing
Set swRefModel = Nothing
End Sub

Le but de cette 2ème macro et de copier toute les feuilles d'une MEp (exemple;: feuille1 et feuille2)

D'ajouter -SYM au nouvelles feuilles (exemple: Feuille1-SYM, Feuille2-SYM) puis de changer les référence de toute les vues pour la configuration symétrique.

Ce code devrait répondre à une partie de tes questions pour changer de configurations. A toi de regarder et de trier.

3

Parfait c'est super merci. Par contre zSmartCat_SYM1 et zBomMaterials ne sont pas défini. Comment dois-je les définir ?  

Cordialement

4

Pour zSmartCat_SYM c'est un module qui récupère le nom des configurations:

Sub smartCat_SYM()
Const suffixNomFichier      As String = "-SYM"
Dim swApp                   As SldWorks.SldWorks
Dim swModel                 As SldWorks.ModelDoc2
Dim swConfig                As SldWorks.Configuration
Dim swCustPropMgr           As SldWorks.CustomPropertyManager
Dim configNames             As Variant
Dim configName              As Variant
Dim lRetVal                 As Long
Dim PathName                As String
Dim bRet                    As Boolean
Dim errorsSave              As Long
Dim warnings                As Long
Dim lectureSeule            As Boolean
Dim configSym               As Boolean
Dim fichierNotSave          As Boolean

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

lectureSeule = False
configSym = False

'On vérifie si la propriété existe déjà si oui on sort de la macro
    'Pour toutes les configurations du modèle 3D
    configNames = swModel.GetConfigurationNames
        For Each configName In configNames
        Debug.Print "2-Nom de config:" & configName
        Set swConfig = swModel.GetConfigurationByName(configName)
        Set swCustPropMgr = swConfig.CustomPropertyManager
    
        If configName Like "*Sym*" Then
                If configName Like "*Sym*Sym*" Then
                    MsgBox "Attention Symétrie de Symétrie merci de corriger votre assemblage et supprimer cette configuration: " & configName
                End If
                'Dim cfg As String
                'cfg = swModel.GetActiveConfiguration.Name
                If swModel.GetCustomInfoValue(configName, "Symetrie") <> "" Then
                    Exit Sub
                End If
            End If
        Next

Pour zBomMaterials, cela traite quelques modification sur la table de nomenclature (changement de config et redimensionnement d'une ou 2 colonnes:

Dim swApp As SldWorks.SldWorks
Dim swDraw As SldWorks.DrawingDoc

Sub bomMaterials()

    Set swApp = Application.SldWorks
    
    Set swDraw = swApp.ActiveDoc
    
    Dim vSheetNames As Variant
    
    vSheetNames = swDraw.GetSheetNames
    
    Dim i As Integer
        
    For i = 0 To UBound(vSheetNames)
        
        Dim swSheet As SldWorks.Sheet
        Set swSheet = swDraw.Sheet(vSheetNames(i))
        Debug.Print "Feuille:" & vSheetNames(i)
        Dim swView As SldWorks.View
        Set swView = GetPropertiesView(swSheet)
        
        Dim vBomFeatures As Variant
        vBomFeatures = GetBomFeatures(swSheet)
        ProcessView swView, vBomFeatures
        'On relance pour redimensionner les colonnes
        vBomFeatures = GetBomFeatures(swSheet)
    Next
    
End Sub

Sub ProcessView(swView As SldWorks.View, vBomFeatures As Variant)
    
    If Not IsEmpty(vBomFeatures) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vBomFeatures)
            
            Dim swBomFeat As SldWorks.BomFeature
            
            Set swBomFeat = vBomFeatures(i)
            
            Dim vConfVis As Variant
            Dim vConfNames As Variant
            vConfNames = swBomFeat.GetConfigurations(False, vConfVis)

            Dim visConfIndex As Integer
            
            Dim j As Integer
            
            For j = 0 To UBound(vConfNames)
                
                vConfVis(j) = UCase(vConfNames(j)) = UCase(swView.ReferencedConfiguration)
                           Debug.Print "vConfNames=" & vConfNames(j)
            Next
            'On change la configuration
            swBomFeat.SetConfigurations False, vConfVis, vConfNames
            
        Next
        
    End If
    
End Sub

Function GetBomFeatures(swSheet As SldWorks.Sheet) As Variant
    
    Dim vSheets As Variant
    vSheets = swDraw.GetViews()
    
    Dim i As Integer
    
    For i = 0 To UBound(vSheets)
    
        Dim vViews As Variant
        vViews = vSheets(i)
        
        Dim swSheetView As SldWorks.View
        Set swSheetView = vViews(0)
        
        If UCase(swSheetView.Name) = UCase(swSheet.GetName()) Then
            
            Dim swBomFeatures() As SldWorks.BomFeature
            
            Dim vTables As Variant
            vTables = swSheetView.GetTableAnnotations()
            
            Dim j As Integer
            Dim isArrInit As Boolean
            If IsEmpty(vTables) Then
            'If vTables = "" Then
            Debug.Print "On sort de la macro"
            Exit Function
            End If
            
            For j = 0 To UBound(vTables)
                
                Dim swTableAnn As SldWorks.TableAnnotation
                Set swTableAnn = vTables(j)
                
                If swTableAnn.Type = swTableAnnotationType_e.swTableAnnotation_BillOfMaterials Then
                    If False = isArrInit Then
                        isArrInit = True
                        ReDim swBomFeatures(0)

                    Else
                        ReDim Preserve swBomFeatures(UBound(swBomFeatures) + 1)

                    End If
                    
                    Dim swBomTableAnn As SldWorks.BomTableAnnotation
                    Set swBomTableAnn = swTableAnn
                    
                    Set swBomFeatures(UBound(swBomFeatures)) = swBomTableAnn.BomFeature
                        'Ajout SD redim colonne
                        SetColumnWith swTableAnn
                        'Fin ajout SD redim colonne
                End If
                
            Next
            
            GetBomFeatures = swBomFeatures

            Exit Function
        End If
        
    Next
    
End Function

Function GetPropertiesView(swSheet As SldWorks.Sheet) As SldWorks.View
    
    Dim vViews As Variant
    
    vViews = swSheet.GetViews
    
    If Not IsEmpty(vViews) Then
        
        Dim i As Integer
        
        For i = 0 To UBound(vViews)
            
            Dim swView As SldWorks.View
            Set swView = vViews(i)
            
            If UCase(swView.Name) = UCase(swSheet.CustomPropertyView) Then
                Set GetPropertiesView = swView
                Exit Function
            End If
            
        Next
        
        Set GetPropertiesView = vViews(0) 'use first one
        
    End If
    
End Function
Sub SetColumnWith(swTable As TableAnnotation)
    Dim index As Integer
    Dim swAnnotation As Annotation
    Dim swDislplayData As DisplayData
    Dim i As Integer
    Dim UserPref As Integer
    Dim UserPrefOption As Integer
    Dim swTextFormat As SldWorks.TextFormat
     
    Set swAnnotation = swTable.GetAnnotation
    Set swDislplayData = swAnnotation.GetDisplayData
    'On dimensionne la taille de la police de document pour les nomenclatures
    Set swTextFormat = swAnnotation.GetTextFormat(1)
        swTextFormat.CharHeightInPts = "10"
        swTextFormat.TypeFaceName = "Arial"
        swTextFormat.Bold = False
        swTextFormat.Italic = False
        'on modifie la propriété font du document pour les nomenclature
        bRet = swDraw.Extension.SetUserPreferenceTextFormat(swUserPreferenceTextFormat_e.swDetailingBillOfMaterialTextFormat, swDetailingBillOfMaterial, swTextFormat)
  
        For i = 0 To swTable.ColumnCount - 1
            Dim ColumnWidth As Double
            ColumnWidth = swTable.GetColumnWidth(i)
            'Debug.Print i & ":" & ColumnWidth * 1000
            'Debug.Print "Title" & swTable.GetColumnTitle(i)
            If i = 0 Then bRet = swTable.SetColumnWidth(i, 0.005, 0)
            If i = 1 Then bRet = swTable.SetColumnWidth(i, 0.0135, 0)
            If i = 2 Then bRet = swTable.SetColumnWidth(i, 0.0295, 0)
            If i = 3 Then bRet = swTable.SetColumnWidth(i, 0.098, 0)
            If i = 4 Then bRet = swTable.SetColumnWidth(i, 0.02, 0)
            If i = 5 Then bRet = swTable.SetColumnWidth(i, 0.024, 0)
        Next
    End Sub

La macro en entier en pièce jointe si besoin


mep_decoupe__symetrie.swp
5

Merci c'est top.

Bonne journée,

Cordialement