Modification code macro PDF/DWG-STEP

Si tu prends le code du 5ème message , il met bien les fichier dans les répertoires pdf Dwg et Step.
Je pense que tu mélanges les pinceaux avec les différents versions de la macro.
Voici l’exemple déjà mis plus haut:
image

1 « J'aime »

Effectivement autant pour moi je n’ai bien regarder désolé pour tout ces échanges !

J’ai juste une petite remarque, le dossier STEP est crée dans le dossier Mise en plan, et je voudrais qu’il soit crée dans le dossiers pièces. Voici l’arborescence de mes fichiers :
1-Assemblage
2-Pièces / STEP
3-Mise en plan / PDF - /DWG

En ajoutant quelques chose comme cela cela devrait être mieux (non testé):

'On revient un dossier en arrière puis on ajoute le dossier Pièces
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePath = sFilePath & "Pièces\"

L’emplacement ou ajouter le code:
image

J’ai un message d’erreur avec le message chemin introuvable avec la ligne " MkDir sFilePath & « Step" » surligné

Si le dossier pièces n’existe pas, mkdir ne peut pas créer des dossiers et sous-dossier en une commande.

1 « J'aime »

Surement un \ en trop ou en moins quel est la valeur de sFilePath juste avant?
Au besoin pour la verifier
ajout de debug.print sFilepath, juste en dessous des 3 lignes précédentes et regarder la valeure dans la fenêtre « Execution » via edition de macro affichage

1 « J'aime »

J’ai l’impression qu’il ne revient pas en arrière car il ajoute le dossiers pièces au dossiers mise en plan

Est-ce que le dossier pièces existe systématiquement et est toujours codifié de la même façon?
En gros pour exemple est-ce ce type d’arborescence?
C:\xxxx\Pièces
C:\xxxx\Mises plans

Oui le dossier pièces existe toujours avec le même nom " 2 - Pieces"

En gros, non optimisé et pas de vérification si les fichiers existent déjà:

Option Explicit

 
Dim swApp                       As SldWorks.SldWorks
Dim swModel                     As SldWorks.ModelDoc2
Dim swDraw                      As SldWorks.DrawingDoc
Dim swView                      As SldWorks.View
Dim swConfig                    As SldWorks.Configuration

Dim vSheetNameArr               As Variant
Dim vSheetName                  As Variant

Dim I                           As Long
Dim nDocType                    As Long
Dim op                          As Long
Dim suppr                       As Long
Dim lErrors                     As Long
Dim lWarnings                   As Long

Dim boolstatus                  As Boolean
Dim bRet                        As Boolean
Dim FileConnu                   As Boolean

Dim nbConnu                     As Integer

Dim sModelName                  As String
Dim sPathName                   As String
Dim TabConnu(10000)             As String
Dim sConfigName                 As String
Dim sModelFullPath              As String
Dim sFilePath                   As String
Dim sFilePathStep               As String
Dim sFileName                   As String
Dim sFileNameWithoutExtension   As String
Dim fs                          As Scripting.FileSystemObject

Const dxfSubFolder = "dwg\"
Const pdfSubFolder = "pdf\"
Const stepSubFolder = "2 - Pieces\step\"

Sub main()

Set swApp = Application.SldWorks
boolstatus = swApp.SetUserPreferenceIntegerValue(swStepAP, 214) 'Force la version AP214
boolstatus = swApp.SetUserPreferenceIntegerValue(swStepExportPreference, swAcisOutputGeometryPreference_e.swAcisOutputAsSolidAndSurface) 'Force l'export en format Solid/Surface Geometry

Set swModel = swApp.ActiveDoc

' PathName of current model document
sModelFullPath = swModel.GetPathName

' get path name without filename
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePathStep = Left(sFilePath, InStrRev(sFilePath, "\", Len(sFilePath) - 1))
Debug.Print sFilePathStep
' get filename and extension
sFileName = Right(sModelFullPath, Len(sModelFullPath) - InStrRev(sModelFullPath, "\"))

' get filename without extension
sFileNameWithoutExtension = Left(sFileName, InStrRev(sFileName, ".") - 1)



Debug.Print sFilePath & pdfSubFolder & sFileNameWithoutExtension & ".pdf"
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
CreateRep (sFilePath & pdfSubFolder)
swModel.Extension.SaveAs sFilePath & pdfSubFolder & sFileNameWithoutExtension & ".pdf", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings

'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
CreateRep (sFilePath & dxfSubFolder)
swModel.Extension.SaveAs sFilePath & dxfSubFolder & sFileNameWithoutExtension & ".dwg", swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, lErrors, lWarnings

'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier
CreateRep (sFilePathStep & stepSubFolder)

Call ExportStep

End Sub
Function CreateRep(sRep As String)
Set fs = New Scripting.FileSystemObject
If Not fs.FolderExists(sRep) Then
    fs.CreateFolder (sRep)
End If
Set fs = Nothing
End Function
Sub ExportStep()
Set swDraw = swModel
vSheetName = swDraw.GetSheetNames
vSheetNameArr = swDraw.GetSheetNames

For Each vSheetName In vSheetNameArr
        
    bRet = swDraw.ActivateSheet(vSheetName): Debug.Assert bRet
    Set swView = swDraw.GetFirstView 'Sélectionne le fond de plan
    Set swView = swView.GetNextView  'Passe à la vue suivante pour exclure le fond de plan
                
    While Not swView Is Nothing
           
        ' Determine if this is a view of a part or assembly

        sModelName = swView.GetReferencedModelName

        sModelName = LCase(sModelName)
                        
        sConfigName = swView.ReferencedConfiguration
        
        FileConnu = False
        
        If InStr(sModelName, "sldprt") > 0 Then
            nDocType = swDocPART
        ElseIf InStr(sModelName, "slasm") > 0 Then
            nDocType = swDocASSEMBLY
        Else
            nDocType = swDocNONE
            Exit Sub
        End If
                       
        If nDocType = 1 Then
            For I = 1 To nbConnu
                If UCase(sModelName) & " - " & UCase(sConfigName) = TabConnu(I) Then
                    FileConnu = True
                End If
            Next
            If Not FileConnu Then
                nbConnu = nbConnu + 1
                TabConnu(nbConnu) = UCase(sModelName) & " - " & UCase(sConfigName)
                Call Export
            End If
        End If
        
        Set swView = swView.GetNextView
    Wend

Next vSheetName



End Sub
Sub Export()
Set swModel = swApp.ActivateDoc3(sModelName, True, swOpenDocOptions_Silent, lErrors)
Set swModel = swApp.ActiveDoc
boolstatus = swModel.ShowConfiguration2(sConfigName)
Set swConfig = swModel.GetActiveConfiguration
sPathName = sFilePathStep & stepSubFolder & sFileNameWithoutExtension & ".step"
If Dir(sPathName, vbHidden) <> "" Then              'Test l'existence du fichier
    suppr = MsgBox("Le fichier " & sPathName & " existe déjà, voulez vous le supprimer?", vbYesNo) 'Message utilisateur confirmation de suppression oui/non
        If suppr = vbYes Then                       'Réponse Oui
            Kill (sPathName) 'Suppression du fichier existant
            swModel.SaveAs2 sPathName, 0, True, False  'Enregistrement du fichier
            op = MsgBox("Le fichier a été enregistré sous " & sPathName & vbNewLine)
            Else                                    'Réponse NON
        MsgBox ("Fichier conservé")                 'Message utilisateur
        End If
        Else
        swModel.SaveAs2 sPathName, 0, True, False      'Enregistrement du fichier
        op = MsgBox("Le fichier a été enregistré sous " & sPathName) 'Message utilisateur
    End If
swApp.CloseDoc (sModelName)
Set swModel = swApp.ActiveDoc
End Sub

Pour que ça fonctionne faut sélectionner « Microsoft Scripting Runtime » dans les références:
image

1 « J'aime »

J’ai repris le code de @sbadenis donc je n’ai plus les 3 variables de chemin

C’est le même code uniquement modifié pour la partie création de dossiers.

1 « J'aime »

sur cette partie de code je dois changer quoi pour que la macro fonctionne ?

'On revient un dossier en arrière puis on ajoute le dossier Pièces
sFilePath = Left(sModelFullPath, InStrRev(sModelFullPath, "\"))
sFilePath = sFilePath & "2 - Pièces\"
'On vérifie si le dossier de sauvegarde existe sinon création de ce dossier STEP
If Dir(sFilePath & "Step\", vbDirectory) = vbNullString Then
    MkDir sFilePath & "Step\"
End If
sFilePath = Left(sFilePath, InStrRev(sFilePath, "\", Len(sFilePath) - 1))
sFilePath = sFilePAth & "2 - Pièces\"

Super Merci pour tout