Macro pour générer en .pdf et incrémenter le nom du fichier si nom déjà existant

fred2705

XLDnaute Junior
Bonjour,
Grace à une macro je cherche à enregistrer ma feuille sous un répertoire donné avec un nom de fichier défini par plusieurs cellules la voici et elle fonctionne :



Code:
Option Explicit

Sub PdfCreator()
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String

sNomPDF = ActiveSheet.Range("P1").Text & "__" & ActiveSheet.Range("F1").Text & "__" & ActiveSheet.Range("M1").Text
    sCheminPDF = "O:\DEV & Q PRODUITS\1 - DEVELOPPEMENT PRODUITS\Calculations prix\PDF généré\"

    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")

    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNomPDF

        .cOption("AutosaveStartStandardProgram") = 1
        .cOption("UpdateInterval") = 0

        '   0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With

    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"

    'Fichier dans la file d'attente
    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
    JobPDF.cPrinterStop = False

    'Attendre que la file d'attente soit vide
    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    JobPDF.cClose
    Set JobPDF = Nothing


Range("O639").Select
    Selection.Copy
    Range("V643").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub


[B]Mais en plus j’aimerais que si le nom existe déjà il soit automatiquement incrémenté de 1.

Voici mon ébauche avec l’incrémentation mais elle ne fonctionne pas merci pour votre aide ?[/B]

Sub PdfCreator()
Dim JobPDF As Object
Dim sNomPDF As String, i As Byte
Dim sCheminPDF As String


sNomPDF = ActiveSheet.Range("P1").Text & "__" & ActiveSheet.Range("F1").Text & "__" & ActiveSheet.Range("M1").Text
sCheminPDF = "O:\DEV & Q PRODUITS\1 - DEVELOPPEMENT PRODUITS\Calculations prix\PDF généré\"



  ' Vérifier si le fichier existe
sNomPDF = Dir(sCheminPDF & ActiveSheet.Range("P1").Text & "__" & ActiveSheet.Range("F1").Text & "__" & ActiveSheet.Range("M1").Text)
  If sNomPDF <> "" Then
    ' S'il existe, incrémenter le nom
    Do
      ' Incrémenter
      i = i + 1
      ' Vérifier s'il existe un nom de fichier identique, renvoie "" si faux
      sNomPDF = Dir(sCheminPDF & ActiveSheet.Range("P1").Text & "__" & ActiveSheet.Range("F1").Text & "__" & ActiveSheet.Range("M1").Text & "-" & i)
    ' Recommencer tant qu'il existe un nom de fichier identique
    Loop While sNomPDF <> ""

 ' Impession PDF

    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")

    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNomPDF

        .cOption("AutosaveStartStandardProgram") = 1
        .cOption("UpdateInterval") = 0

        '   0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With

    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"

    'Fichier dans la file d'attente
    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
    JobPDF.cPrinterStop = False

    'Attendre que la file d'attente soit vide
    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    JobPDF.cClose
    Set JobPDF = Nothing

End Sub
Merci???
 
Dernière édition:

kiki29

XLDnaute Barbatruc
Re : Macro pour sauvegarder en pdf en incrémenter

Salut, une liste qui te permettra de naviguer dans le bazar, la réponse pour l'incrément de 1 y est pour certaines de ces contributions pour sauvegarder des fichiers sans doublons elle s'appelle RenommerFichier.


PS : Balise ton code et corrige le titre de ton post qui ne veut rien dire
 
Dernière édition:

kiki29

XLDnaute Barbatruc
Re : Fonction pour sauvegarder un fichier sans doublons : en incrémentant un N°

Salut,
Code:
Option Explicit

Private Function RenommerFichier(sChemin As String, sNomFichier As String) As String
Dim sNouveauNom As String
Dim sPre As String
Dim sExt As String
Dim iExt As Long
Dim i As Long, Pos As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.fileExists(sChemin & "\" & sNomFichier) = True Then
        sNouveauNom = sNomFichier
        Pos = InStrRev(sNomFichier, ".")
        iExt = Len(sNomFichier) - Pos + 1
        If Pos > 0 Then
            sExt = Right$(sNomFichier, iExt)
            sPre = Left$(sNomFichier, Len(sNomFichier) - iExt)
        Else
            sExt = ""
            sPre = sNomFichier
        End If
 
        i = 0
        While FSO.fileExists(sChemin & "\" & sNouveauNom) = True
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & sExt
            'sNouveauNom = sPre & "_" & Format(i, "000") & sExt
        Wend
        sNomFichier = sNouveauNom
    End If
    Set FSO = Nothing
    RenommerFichier = sChemin & "\" & sNomFichier
End Function

en l'intégrant dans ton code initial
Code:
Option Explicit

Sub PdfCreator()
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
Dim sNouveauNomPDF As String

    sNomPDF = ActiveSheet.Range("P1").Text & "_" & _
            ActiveSheet.Range("F1").Text & "_" & _
            ActiveSheet.Range("M1").Text
    sCheminPDF = "O:\DEV & Q PRODUITS\1 - DEVELOPPEMENT PRODUITS\Calculations prix\PDF généré\"

    sNouveauNomPDF = RenommerFichier(sCheminPDF, sNomPDF)

    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")

    With JobPDF
    .....
         .cOption("AutosaveDirectory") = sCheminPDF
         .cOption("AutosaveFilename") = sNouveauNomPDF
    .....
 
Dernière édition:

fred2705

XLDnaute Junior
Re : Macro pour sauvegarder en pdf en incrémenter

Merci bcp pour ta réponse.

J'ai inséré le code si dessous dans un module mais maintenant il m'enregistre également le nom du répertoire! :
O__DEV & Q PRODUITS_1 - DEVELOPPEMENT PRODUITS_Calculations prix_PDF généré__P12.12.12_Contact_12.11.2014

Et si j actionne une deuxième fois la macro il écrase simplement le fichier et ne créé pas une incrémentation!

Désolé, mais je n'ai pas le niveau pour résoudre ce genre de code!!! Donc merci encore de votre aide

Code:
Option Explicit

Private Function RenommerFichier(sChemin As String, sNomFichier As String) As String
Dim sNouveauNom As String
Dim sPre As String
Dim sExt As String
Dim iExt As Long
Dim i As Long, Pos As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.fileExists(sChemin & "\" & sNomFichier) = True Then
        sNouveauNom = sNomFichier
        Pos = InStrRev(sNomFichier, ".")
        iExt = Len(sNomFichier) - Pos + 1
        If Pos > 0 Then
            sExt = Right$(sNomFichier, iExt)
            sPre = Left$(sNomFichier, Len(sNomFichier) - iExt)
        Else
            sExt = ""
            sPre = sNomFichier
        End If
 
        i = 0
        While FSO.fileExists(sChemin & "\" & sNouveauNom) = True
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & sExt
            'sNouveauNom = sPre & "_" & Format(i, "000") & sExt
        Wend
        sNomFichier = sNouveauNom
    End If
    Set FSO = Nothing
    RenommerFichier = sChemin & "\" & sNomFichier
End Function





Sub PdfCreator()
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
Dim sNouveauNomPDF As String

    
    
    
    sNomPDF = ActiveSheet.Range("P1").Text & "_" & _
            ActiveSheet.Range("F1").Text & "_" & _
            ActiveSheet.Range("M1").Text
    
    sCheminPDF = "O:\DEV & Q PRODUITS\1 - DEVELOPPEMENT PRODUITS\Calculations prix\PDF généré\"

    sNouveauNomPDF = RenommerFichier(sCheminPDF, sNomPDF)

    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")

    
    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNouveauNomPDF

        .cOption("AutosaveStartStandardProgram") = 1
        .cOption("UpdateInterval") = 0

        '   0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With

    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"

    'Fichier dans la file d'attente
    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
    JobPDF.cPrinterStop = False

    'Attendre que la file d'attente soit vide
    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    JobPDF.cClose
    Set JobPDF = Nothing


Range("O639").Select
    Selection.Copy
    Range("V643").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub
 

kiki29

XLDnaute Barbatruc
Fonction pour sauvegarder un fichier sans doublons : en incrémentant un N°

Salut, tu pourrais baliser l'ensemble de tes posts et donner un titre plus explicite : cela facilitera les éventuelles recherches futures

Sinon du fait que PDFCreator ajoute de lui-même une extension, il y a qqs aménagements à faire
ici cela fonctionne correctement ( voir snapshot )
Code:
Option Explicit

Private Function RenommerFichier(sChemin As String, sNomFichier As String) As String
Dim sNouveauNom As String
Dim sPre As String
Dim sExt As String
Dim iExt As Long
Dim i As Long, Pos As Long
Dim FSO As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.fileExists(sChemin & "\" & sNomFichier & ".pdf") = True Then
        sNouveauNom = sNomFichier
        Pos = InStrRev(sNomFichier, ".")
        iExt = Len(sNomFichier) - Pos + 1
        If Pos > 0 Then
            sExt = Right$(sNomFichier, iExt)
            sPre = Left$(sNomFichier, Len(sNomFichier) - iExt)
        Else
            sExt = ""
            sPre = sNomFichier
        End If
 
        i = 0
        While FSO.fileExists(sChemin & "\" & sNouveauNom & ".pdf") = True
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & sExt
        Wend
        sNomFichier = sNouveauNom
    End If
    Set FSO = Nothing
    RenommerFichier = sNomFichier
End Function

Sub PdfCreator()
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
Dim sNouveauNomPDF As String
Dim FSO As Object

    ' le nom du PDF sans extension car PDFCreator l'ajoute ...
    sNomPDF = "Essai"
    sCheminPDF = ThisWorkbook.Path & "\" & "Essais"
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(sCheminPDF) Then FSO.CreateFolder (sCheminPDF)
    Set FSO = Nothing
    
    sNouveauNomPDF = RenommerFichier(sCheminPDF, sNomPDF)

    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")
   
    With JobPDF
        .cStart "/NoProcessingAtStartup"
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNouveauNomPDF

        .cOption("AutosaveStartStandardProgram") = 0
        .cOption("UpdateInterval") = 0
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With

    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"

    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
    JobPDF.cPrinterStop = False

    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    JobPDF.cClose
    Set JobPDF = Nothing
End Sub
 

Pièces jointes

  • IMG317.jpg
    IMG317.jpg
    26.6 KB · Affichages: 67
Dernière édition:

fred2705

XLDnaute Junior
Re : Macro pour sauvegarder en pdf en incrémenter

Yes...merci bcp ça marche :D

Il y à juste encore une petite chose, l'incrémentation se fait au milieu de la date, est il possible de la mettre a la fin du nom du fichier?

Voici l'exemple de ce que ça me donne en image ci-joint

Encore merci.
 

Pièces jointes

  • PDF incrémenté.jpg
    PDF incrémenté.jpg
    12.2 KB · Affichages: 77

kiki29

XLDnaute Barbatruc
Re : Macro pour sauvegarder en pdf en incrémenter

Salut, tu as fait le choix d'avoir des . dans ton nom de fichier : mauvaise pioche ....

Tu pourrais baliser l'ensemble de tes posts et donner un titre plus explicite : cela facilitera les éventuelles recherches futures
 

fred2705

XLDnaute Junior
Re : Macro pour générer un pdf avec incrémentation du nom de fichier si déjà existant

Je suis malheureusement obligé d'avoir ces points !:mad:

Mon fichier .pdf s'ouvrait automatiquement lors de la sauvegarde, ce n'est plus le cas, est-il possible de réactiver son ouverture?

Merci merci!
 

kiki29

XLDnaute Barbatruc
PDFCreator : générer un pdf et incrémenter nom du fichier si déjà existant

Salut, cela devrait te satisfaire
Code:
Option Explicit

Private Function RenommerFichier(sChemin As String, sNomFichier As String) As String
Dim sNouveauNom As String
Dim i As Long
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.fileExists(sChemin & "\" & sNomFichier & ".pdf") = True Then
        sNouveauNom = sNomFichier
        i = 0
        While FSO.fileExists(sChemin & "\" & sNouveauNom & ".pdf") = True
            i = i + 1
            sNouveauNom = sNomFichier & Chr(40) & Format(i, "000") & Chr(41)
        Wend
        sNomFichier = sNouveauNom
    End If
    Set FSO = Nothing
    RenommerFichier = sNomFichier
End Function

Sub PdfCreator()
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
Dim sNouveauNomPDF As String

    sNomPDF = .......
    sCheminPDF =.............
    
    sNouveauNomPDF = RenommerFichier(sCheminPDF, sNomPDF)

    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")

    With JobPDF
        .cStart "/NoProcessingAtStartup"
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNouveauNomPDF

        .cOption("AutosaveStartStandardProgram") = 1
        .cOption("UpdateInterval") = 0
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With

    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"

    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
    JobPDF.cPrinterStop = False

    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    JobPDF.cClose
    Set JobPDF = Nothing
End Sub
 
Dernière édition:

Discussions similaires