Macro création de plan automatique

Bonjour,

Je suis actuellement entrain de réaliser une macro en VBA(je débute dans le codage) qui à partir d’un document ouvert créer une nouvelle page avec un cartouche spécifique, renommer « rev » et qui met une vue au milieu du dessin. Mais je n’arrive pas à mettre une configuration particulière plus précisément la première (peu importe le document). voici le code :


Dim swApp As Object
Dim Part As IDrawingDoc
Dim nomdoc As String
Dim boolstatus As Boolean
Dim myview As SldWorks.View
Dim swSketchMgr As Object
Dim swSketch As Object
Sub main()
Set swApp = CreateObject(« SldWorks.Application »)
Set Part = swApp.ActiveDoc
nomdoc = Part.GetPathName
If nomdoc = «  » Then
MsgBox " enregistrer le document"
End If
nomdoc = Replace(nomdoc, « .SLDDRW », «  »)
nomdoc = nomdoc & « .sldprt »
boolstatus = Part.NewSheet3(« REV », 12, 12, 1, 1, True, « DIAGER RVT2.slddrt », 0.42, 0.297, « Par défaut »)

Part.ViewZoomtofit2
Part.ClearSelection2 True
Set myview = Part.CreateDrawViewFromModelView3(nomdoc, « *Face », 0.42 / 2, 0.297 / 2, 0)
Part.ForceRebuild
Set myview = Part.GetFirstView
boolstatus = Part.ChangeRefConfigurationOfFlatPatternView(nomdoc, « <Défaut(01)> »)
Part.ForceRebuild
End Sub


Passer d’une configuration comme ca :

à ça :

sauf que rien ne se fait lorsque je lance la macro (pas d’erreur et pas de changement dans la vue) et mon dernier boolstatus est pourtant vrai.
avez-vous une idée ?

Par avance merci
Yohann

Tu utilise un changement de vue pour un flatpattern, ce qui visiblement n’est pas le cas.
Pour changer la config d’une vue j’utilise:
swView.ReferencedConfiguration = vConfs(saveJ)

Voici le code complet si besoin:

Option Explicit
Option Compare Text 'ignore la casse lors des comparaisons de texte Ex "aaa" =" AAA"
'MAJ17/01/2023 SD Modification avec supression de la vérif fraisage et symétrisation systématique de la vue dépli pour les feuilles sym
'MAJ 22/09/2022 SD
'MAJ 2022-09-30 Ajout de la laison de la vue avec la nomenclature: voir -> On récupère le nom de la dernière nomenclature pour les feuilles SYM
'Const iDrwTempSize  As Long = swDwgPaperSizes_e.swDwgPaperA0size
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()
sDrTemplateLaser = "U:\Entreprise\Service BE\1-Commun service\Solidworks\Configuration\Modèle de documents\Modèle SW 2020\Fond de plan C\A4-DECOUPE-c.DRWDOT"
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
'On vide la sélection de feuille en cours
 swModel.ClearSelection2 True
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
            
        'Suppression de la partie inversion de la vue par symétrisation systématique de la vue
        '    'On vérifie si la feuille contient un ou plusieur fraisage -> <HOLE-SINK>
        '
        '        Debug.Print "  View = " & swView.Name
        '        Dim swDispDim                   As SldWorks.DisplayDimension
        '        Dim swDim                       As SldWorks.Dimension
                Dim swAnn                       As SldWorks.Annotation
        '        Dim threadPrefix                As String
        '        Set swDispDim = swView.GetFirstDisplayDimension5
        '        Do While Not swDispDim Is Nothing

        '            Set swAnn = swDispDim.GetAnnotation
        '            Set swDim = swDispDim.GetDimension
        '            threadPrefix = CStr(swDispDim.GetText(swDimensionTextPrefix))
        '            Debug.Print threadPrefix
        '            Set swDispDim = swDispDim.GetNext3
        '            'Si le  suffixe de la côte est fraisée -> <HOLE-SINK>
        '            Dim fraisage As String
        '            fraisage = "Non"
        '            If Left(threadPrefix, 11) = "<HOLE-SINK>" Then
        '            Debug.Print "Fraisage"
        '            fraisage = "Oui"
        '            Else
        '            Debug.Print "Pas de fraisage"
        '            fraisage = "Non"
        '            End If
        '        Loop
            

            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*" And Not confName Like "Sym*Flat*" 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
            Debug.Print "Nom de la feuille active: " & swDraw.GetCurrentSheet.GetName
             
            'On récupère le nom de la dernière nomenclature pour les feuilles SYM
            Dim swFeat      As SldWorks.Feature
            Dim swBomFeat   As SldWorks.BomFeature
            Dim BomName As String
            Set swFeat = swDraw.FirstFeature
            Do While Not swFeat Is Nothing
                If (swFeat.GetTypeName = "BomFeat") Then
                    Debug.Print "******************************"
                    Debug.Print "Feature Name = " & swFeat.Name
                    BomName = swFeat.Name
                End If
                Set swFeat = swFeat.GetNextFeature
            Loop


            
            '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)
                    'On lie la vue à la nomenclature
                    If BomName <> vbNullString Then
                        bRet = swView.SetKeepLinkedToBOM(True, BomName)
                    End If
                    
                Else
                    'Modif code symétrisation systématique de la vue déplié
                    'On retourne la vue si pas pièce pas fraisée
                    'If fraisage = "Non" Then
                    '    'Debug.Print "On retourne la vue"
                    '    If swView.FlipView = False Then
                    '        swView.FlipView = True
                    '    Else
                    '        swView.FlipView = False
                    '    End If
                    'Else 'Fraisage="Oui"
                    
                    'Cocher Symétrie de la vue horizontal
                    Dim mirrored As Boolean
                    Dim orientation As Long
                    swView.SetMirrorViewOrientation True, swMirrorViewPositions_e.swMirrorViewPosition_Horizontal
                    swView.GetMirrorViewOrientation mirrored, orientation
                    Debug.Print "Mirrored? " & mirrored
                    Debug.Print "Orientation (0 = horizontal)? " & orientation

                    'End If
                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




2 Likes

Bonjour,

merci pour votre aide, j’ai réussi à bidouiller quelque chose.
cordialement,
Yoh.

Si résolu merci de bien vouloir sélectionner la meilleurs réponse et éventuellement ajouter ta solution final (avec texte préformaté pour la partie code si possible), cela pourrait aider quelqu’un dans le futur.
image

Merci.
Ps: Merci @Maclane pour l’image, je kiffe! :crazy_face: