Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11

Imprimer en PDF tout le classeur, par macro

11 réponses
Avatar
Greg
Bonjour,

Je souhaite, à partir d'un classeur excel contenant plusieurs feuilles,
produire des fiches au format PDF. Le classeur contient des nombres
aléatoires, et l'actualisation du classeur par la touche F9 me permet de
produire des fiches différentes entre chaque impression. Je souhaite
produire une trentaine de fiches pour chaque classeur et autant de classeurs
à faire (soit près de 1000 fiches).

Je suis actuellement sous 2007, ce qui m'oblige à faire :
- enregistrer sous ... format PDF
- cocher la case "optimiser pour une taille minimale en vue d'une
publication sur le net"
- ouvrir les options et choisir d'imprimer tout le classeur
- nommer la fiche ("fiche_9" si c'est la neuvième)
- et enfin... Valider....

La démarche est donc très répétitive et plutôt lourde, surtout si je dois
produire 30 fiches pour chaque classeur. J'ai bien tenté l'enregistreur de
macro, mais ça bug.

Pourriez-vous m'aider?

Merci d'avance

Greg

1 réponse

1 2
Avatar
michdenis
Même principe que pour l'autre procédure :

Un nom crée appelé masqué : MesFichiersPDF
qui contient le nom du dernier nom de fichier
attribué et de son index.


Const Délai = 2.5

'Pour imprimer tout le classeur :
'-------------------------------------
Sub test()
Dim Répertoire As String
Dim NomFeuille As String
NomFeuille = ActiveSheet.Name
Répertoire = "C:MonCheminMes Fichiers PDF"
Sheets.Select
Créer_Un_Fichier_PDF Répertoire, True
Sheets(NomFeuille).Select
End Sub

'-------------------------------------
Sub Créer_Un_Fichier_PDF(SpdFpath As String, _
Creation As Boolean)

Dim pdfjob As Object, NbJobs As Integer, Sh As Object
Dim Default_Printer As String, SonNom As String, NbPages As Integer

killtask ("PDFCreator.exe") 'Procédure écrite plus bas...

Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Make sure the PDF printer can start
If pdfjob.cstart("/NoProcessingAtStartup") = False Then
MsgBox "Imposssible d'initialiser PDFCreator.", vbCritical + _
vbOKOnly, "Erreur!"
Exit Sub
End If

NbPages = 0
With ThisWorkbook
For Each Sh In Workbooks(.Name).Worksheets
Temp = "[" & .Name & "]" & Sh.Name
Commande = "get.document(50,""" & Temp & """)"
NbPages = NbPages + ExecuteExcel4Macro(Commande)
Next
End With
If NbPages = 0 Then MsgBox "Aucune feuille à imprimer.": Exit Sub

'La racine du nom du fichier que tu veux
SonNom = "Fiche"
'Appelle la procédure pour incrémenter le nom
'LaProcédure qui un NOM portant l'appellation "MesFichiersPDF"
'dans la collection Names. Sa valeur aura comme racine
'toto" ainsi qu'un index incrémenté
'Ce nom n'est pas visible dans l'interface de la feuille
'de calcul car il est masqué. Il sera sauvegardé en même
'temps que les autres données du fichier

LeNomFichierSuivant SonNom

'Set all defaults
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = SpdFpath
.cOption("AutosaveFilename") = SonNom & ".pdf"
.cOption("AutosaveFormat") = 0
.cClearCache
End With
Application.ScreenUpdating = False
Default_Printer = Application.ActivePrinter
'Imprimer les feuilles sélectionnées
With ActiveWindow
For Each Sh In .SelectedSheets
If TypeName(Sh) = "Chart" Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Else
If Not IsEmpty(Sh.UsedRange) Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Sh.DisplayPageBreaks = False
End If
End If
Next
End With

'Wait until all print jobs have entered the print queue
NbJobs = pdfjob.cCountOfPrintjobs
If NbJobs > 0 Then
Creation = True
Do Until pdfjob.cCountOfPrintjobs = NbJobs
DoEvents
Loop
'Combine all PDFs into a single file and stop the printer
With pdfjob
.ccombineall
.cPrinterStop = False
End With

'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
End If
pdfjob.cClose
Application.ScreenUpdating = True
Application.ActivePrinter = Default_Printer
Set pdfjob = Nothing
End Sub
'-------------------------------------
Sub killtask(sappname As String)
Dim oProclist As Object
Dim oWMI As Object
Dim oProc As Object
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
Set oProclist = oWMI.InstancesOf("win32_process")
For Each oProc In oProclist
If UCase(oProc.Name) = UCase(sappname) Then
oProc.Terminate (0)
End If
Next oProc
Else
MsgBox "Killing """ & sappname & _
""" - Can't create WMI Object.", _
vbOKOnly + vbCritical, "CloseAPP_B"
End If
Set oProclist = Nothing
Set oWMI = Nothing
End Sub
Function Attente(x As Double)
Dim T As Double
T = Timer + x
Do While Timer <= T
DoEvents
Loop
End Function

'-------------------------------------
Sub LeNomFichierSuivant(SonNom As String)
Dim x As Long, N As Name
On Error Resume Next
Set N = ThisWorkbook.Names("MesFichiersPDF")
If Err <> 0 Then Err = 0
If N Is Nothing Then
Set N = ThisWorkbook.Names.Add("MesFichiersPDF", SonNom & " " & 1, False)
SonNom = Evaluate(N.Name)
Else
x = CLng(Split(Evaluate(N.Name), " ")(1)) + 1
ThisWorkbook.Names.Add "MesFichiersPDF", _
Trim(Split(Evaluate(N.Name), " ")(0)) & " " & x, False
SonNom = Evaluate(N.Name)
End If
End Sub
'-------------------------------------

MichD
--------------------------------------------
1 2