VBA - Impression charts du Workbook

Bonjour!
Je possède un fichier avec plusieurs onglets et qui, dans chacun des onglets, a des graphiques. J'essaie d'imprimer en un seul fichier .pdf tous les graphs du classeur. Aujourd'hui, j'utlise ce code mais qui imprime chacun des graph séparément. Est-il possible d'ajuster ce code pour pouvoir faire qu'une seule impression pdf de plusieurs pages? Ou bien un tout nouveau code?

Merci!

Option Explicit
Sub PrintCharts()
'-------------------------------------------------------------------
Application.ScreenUpdating = False
Dim ch As Object
Dim sh As Worksheet
Dim icount As Integer
icount = 0
    'Print Chart Objects
    For Each sh In ActiveWorkbook.Worksheets
        sh.Activate
        For Each ch In sh.ChartObjects
            If ch.Height < ch.Width Then
                ch.Chart.PageSetup.Orientation = xlLandscape
            Else
                ch.Chart.PageSetup.Orientation = xlPortrait
            End If
            icount = icount + 1
            ch.Chart.PrintOut   'PrintOut
        Next ch
    Next sh

    'Print Charts
    For Each ch In ActiveWorkbook.Charts
        icount = icount + 1
        ch.PrintOut
    Next ch

    MsgBox "Printing " & icount & " charts from Workbook " _
        & ActiveWorkbook.Name & ".", vbInformation, "Print Charts"

Application.ScreenUpdating = True
End Sub

Bonjour,

En supposant que vous disposiez de la DLL PDFCREATOR_Com (version 2.5) et que vous imprimiez vos graphes via l'imprimante pdf, le code ci-dessous permet d'assembler vos fichiers. Naturellement, il vous faut indicer vos fichiers pdf pour que cela les récupère dans l'ordre.

Nb : En espérant que la version actuelle de la DLL est compatible avec la version 2.5.

Sub MergePDFViaImpressionPdf()

Dim CtrI As Long
Dim oPDF As PdfCreatorObj
Dim Q As PDFCreator_COM.Queue
Dim job As PDFCreator_COM.PrintJob
Dim CheminFichierFusionne As String, NomFichierFusionne As String, RepertoirePdf As String, ChaineATrouver As String
Dim Fso As Object, Fich As Object

    On Error GoTo Fin

    ChaineATrouver = ".pdf"
    CheminFichierFusionne = ActiveWorkbook.Path & "\"  ' A adapter
    NomFichierFusionne = CheminFichierFusionne & "Fusion 01.pdf"
    RepertoirePdf = ActiveWorkbook.Path & "\Répertoire de fusion"

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set oPDF = New PdfCreatorObj

    With oPDF
         For Each Fich In Fso.getfolder(RepertoirePdf).Files
             If InStr(1, LCase(Fich.Name), ChaineATrouver, vbTextCompare) > 0 Then
                .AddFileToQueue RepertoirePdf & Application.PathSeparator & Fich.Name
             End If
         Next Fich
    End With

    Set Q = New PDFCreator_COM.Queue

    With Q
         .Initialize
         .WaitForJobs 2, 10
         Debug.Print "q.Count: " & Q.Count
         .MergeAllJobs
    End With

    While Q.Count > 0
            Set job = Q.NextJob
            job.SetProfileByGuid ("DefaultGuid")
            job.ConvertTo (NomFichierFusionne) '(OutPath)
    Wend

    Q.ReleaseCom

    MsgBox "Fin de fusion !", vbInformation

    GoTo Fin

Fin:

    Set Fso = Nothing
    Set job = Nothing
    Set Q = Nothing
    Set oPDF = Nothing

End Sub

Très utile! merci bcp!!