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 :
Merci???
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
Dernière édition: