Des zones d’impression d’Excel à PowerPoint

Bon­jour à tous,

Voici un “petit” bout de code en VBA pour trans­fér­er la zone d’im­pres­sion vers Powerpoint.

  • C’est une solu­tion com­plé­men­taire à Power­BI, dans le cas où vous voulez génér­er automa­tique­ment un rap­port Powerpoint. 
  • C’est aus­si une solu­tion com­plé­men­taire aux liaisons directes Excel-Pow­er­point, voir ici par exemple.

La dif­fi­culté du code est dans l’i­den­ti­fi­ca­tion des zones d’im­pres­sion. En effet, on a deux types de sauts de page, hor­i­zon­taux et ver­ti­caux (VPage­Break et HPageBreak)

De plus, ils ne com­men­cent pas dans la pre­mière cel­lule, donc on doit aus­si faire appel à la zone d’im­pres­sion pour iden­ti­fi­er la pre­mière et la dernière cel­lule de la zone d’im­pres­sion range(wksFeuille.PageSetup.PrintArea) :

Après pas mal de tests, voici une solu­tion clef en main en cinq étapes

Mise en place 

1/ Copiez et collez le code dans votre fichi­er Excel

2/ Dans le réper­toire du fichi­er Excel, créez un fichi­er pow­er­point qui servi­ra de mod­èle : Modele.pptx

3/ Mod­i­fiez la vari­able arrFeuilles pour inclure vos pro­pres feuilles (voir l’ex­em­ple dans le début du code)

4/ Lancez le code testGenererPowerpoint

5/ C’est fini !

Sub testGenererPowerPoint()
    ThisWorkbook.Save 'optionnel, juste au cas ou excel plante
    Dim arrFeuilles As Variant, sPathModele As String
    '*** A PARAMETRER 1/2 ***
    '* Liste des feuilles
    arrFeuilles = Array(ActiveSheet.Name)
    'Ou bien:
    arrFeuilles = Array("Graphiques 1", "Graphiques 2")
    '* Chemin du modèle
    sPathModele = fctThisWorkbookPath & "\" & "Modele.pptx"
    '*** FIN DU PARAMETRAGE ***
    'on lance la generation du powerpoint
    GenererPowerPoint2 arrFeuilles, sPathModele
End Sub
Sub GenererPowerPoint2(arrFeuilles As Variant, Optional sPathModele As String)
    If bCheckFileExists(sPathModele) = False Then
    MsgBox "Le fichier modèle n'existe pas : " & vbCrLf & sPathModele, vbOKOnly
    Exit Sub
    End If
    'chemin et nom de sauvegarde, incluant date et heure de generation du fichier
    Dim sCheminFichierFinal  As String
    sCheminFichierFinal = fctThisWorkbookPath & Range("SyntheseClient_Nom_Client").Value & "_" & Application.UserName & "_" & Format(Date, "yyyy-mm-dd") & " à " & Format(Now, "hh-mm-ss") & ".pptx"
    'Variables liees a la zone d'impression
    Dim lRow_CellTopLeft As Long, lCol_CellTopLeft As Long, lRow_CellBottomRight As Long, lCol_CellBottomRight As Long
    Dim vPB As VPageBreak, hPB As HPageBreak, rhPB As Range, rvPB As Range, lhPB As Long, lvPB As Long
    'Variables liees au powerpoint
    Dim PowerPointApp As Object, myPresentation As Object, mySlide As Object, myshape As Object
    Dim lPositionGauche As Long, lPositionTop As Long 'position dans powerpoint
    lPositionGauche = 0: lPositionTop = 0
    Dim iSlide As Integer
    'Autres variables
    Dim rPlageAColler As Range, lFeuille  As Long
    'On cree une instance de powerpoint
    On Error Resume Next:     Set PowerPointApp = GetObject(class:="PowerPoint.Application"):     Err.Clear
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    If Err.Number = 429 Then
        MsgBox "PowerPoint n'a pas été trouvée. Annulation de la procédure."
        Exit Sub
    End If
    On Error GoTo 0
    'on masque le powerpoint. C'est une option qui n'est pas forcement interessante car l'utilisateur pourrait croire que l'application a plante
    'PowerPointApp.Visible = False
    
    
    Application.ScreenUpdating = False
    'On ouvre le modele et on le sauvegarde immediatement. Important si on est sur onedrive, sinon les changements pourraient etre enregistres directement
    Set myPresentation = PowerPointApp.Presentations.Open(sPathModele)
    myPresentation.SaveAs sCheminFichierFinal
    
    iSlide = 1
    
    Dim wksFeuille As Worksheet
    For lFeuille = LBound(arrFeuilles) To UBound(arrFeuilles)
        Set wksFeuille = Worksheets(arrFeuilles(lFeuille))
        If wksFeuille.PageSetup.PrintArea <> "" Then 'il faut une plage d'impression
            'le moteur de calcul : parcourir l'ensemble des plages a imprimer/coller dans le powerpoint
            If wksFeuille.HPageBreaks.Count = 0 And wksFeuille.VPageBreaks.Count = 0 Then 'pas de saut de page horizontal, ni de saut de page vertical
                wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Copy
                EnvoiePressePapierVersPowerpoint myPresentation, lPositionGauche, lPositionTop
                iSlide = iSlide + 1
            Else 'on parcourt toutes les zones, d'un saut de page a l'autre
                For lhPB = 0 To wksFeuille.HPageBreaks.Count
                    For lvPB = 0 To wksFeuille.VPageBreaks.Count
                        If lhPB = 0 Then
                            lRow_CellTopLeft = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Cells(1, 1).Row
                            If wksFeuille.HPageBreaks.Count = 0 Then 'Pas de saut de page horizontal, on considere la zone d'impressoin
                                lRow_CellBottomRight = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Row + wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Rows.Count - 1
                            Else
                                lRow_CellBottomRight = wksFeuille.Range(wksFeuille.HPageBreaks(1).Location.Address).Row - 1
                            End If
                        End If
                    
                        If lvPB = 0 Then
                            lCol_CellTopLeft = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Cells(1, 1).Column
                            If wksFeuille.VPageBreaks.Count = 0 Then 'Pas de saut de page vertical, on considere la zone d'impressoin
                                lCol_CellBottomRight = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Column + wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Columns.Count - 1
                            Else
                                lCol_CellBottomRight = wksFeuille.Range(wksFeuille.VPageBreaks(1).Location.Address).Column - 1
                            End If
                        End If
                
                        If lhPB > 0 Then
                            lRow_CellTopLeft = wksFeuille.Range(wksFeuille.HPageBreaks(lhPB).Location.Address).Row
                            If lhPB = wksFeuille.HPageBreaks.Count Then 'cas de la derniere zone
                                lRow_CellBottomRight = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Row + wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Rows.Count - 1
                            Else
                                lRow_CellBottomRight = wksFeuille.Range(wksFeuille.HPageBreaks(lhPB + 1).Location.Address).Row - 1
                            End If
                        End If
                    
                        If lvPB > 0 Then
                            lCol_CellTopLeft = wksFeuille.Range(wksFeuille.VPageBreaks(lvPB).Location.Address).Column
                            If lvPB = wksFeuille.VPageBreaks.Count Then 'cas de la derniere zone
                                lCol_CellBottomRight = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Column + wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Columns.Count - 1
                            Else
                                lCol_CellBottomRight = wksFeuille.Range(wksFeuille.VPageBreaks(lvPB + 1).Location.Address).Column - 1
                            End If
                        End If
                
                        
                        If lCol_CellTopLeft >= lCol_CellBottomRight Or lRow_CellTopLeft >= lRow_CellBottomRight Then 'on gere le cas ou les sauts de pages ne sont pas consideres
                            'on ne fait rien, je prefere etre explicite dans la condition
                        Else
                            wksFeuille.Range(wksFeuille.Cells(lRow_CellTopLeft, lCol_CellTopLeft), wksFeuille.Cells(lRow_CellBottomRight, lCol_CellBottomRight)).Copy
                            'on copie colle dans powerpoint
                    
                            EnvoiePressePapierVersPowerpoint myPresentation, lPositionGauche, lPositionTop
                            iSlide = iSlide + 1
                        End If
                    Next lvPB
                Next lhPB
            End If
        End If
    Next lFeuille
    
    On Error Resume Next 'au cas ou le parametre n'existe pas dans le powerpoint
    myPresentation.slides(1).Shapes("TextBox 1").TextFrame.TextRange.Replace "[NOM_CLIENT]", Range("SyntheseClient_Nom_Client").Value
    myPresentation.slides(1).Shapes("TextBox 1").TextFrame.TextRange.Replace "[MOIS ANNEE]", UCase(Format(Date, "mmmm yyyy"))
    On Error GoTo 0

    'On rend PowerPoint visible et actif
    PowerPointApp.Visible = True
    PowerPointApp.Activate

    'On vide le presse-papier
    Application.CutCopyMode = False

    'On reactive la mise a jour de l'ecran
    Application.ScreenUpdating = True
End Sub
Sub EnvoiePressePapierVersPowerpoint(myPresentation As Object, lPositionGauche As Long, lPositionTop As Long)
    'ce code permet d'envoyer le conteun du presse papier vers powerpoint
    Dim mySlide As Object, myshape As Object
    Set mySlide = myPresentation.slides.Add(myPresentation.slides.Count, 12)  '11 = ppLayoutTitleOnly, 12 = blank
    'Parfois, le presse papier n'a pas eu le temps de faire sa copie, donc on gere l'erreur ici
    On Error Resume Next
    mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
    If Err.Number <> 0 Then
        On Error GoTo 0
        Application.Wait Now + TimeValue("0:00:03")
        mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
    End If
    On Error GoTo 0
    'on identifie la shape que l'on vient de coller
    Set myshape = mySlide.Shapes(mySlide.Shapes.Count)
    'On lui donne ses coordonnees
    myshape.Left = lPositionGauche
    myshape.Top = lPositionTop
End Sub
Function fctThisWorkbookPath()
    'Cette fonction permet de gerer le cas d'un onedrive
    If bCheckFolderExists(ThisWorkbook.Path) Then
        fctThisWorkbookPath = ThisWorkbook.Path & "\"
    Else
        fctThisWorkbookPath = "C:\Users\" & Environ$("UserName") & "\OneDrive - bizoffice6126\"
    End If
End Function
   
Function bCheckFolderExists(strFolderName As String) As Boolean
    'on verifie que le dossier existe
    Dim strFolderExists As String
    On Error Resume Next
    strFolderExists = Dir(strFolderName, vbDirectory)
    If Err.Number = 0 and strFolderExists <> "" Then
        bCheckFolderExists = True
        Exit Function
    End If
 
    If strFolderExists = "" Then
        bCheckFolderExists = False
    Else
        bCheckFolderExists = True
    End If
 
End Function
Function bCheckFileExists(strFileName As String) As Boolean
bCheckFileExists = Not (Dir(strFileName) = "")
End Function

Options complémentaires :

  • Dans le mod­èle, dans la pre­mière slide, vous pou­vez ajouter une boite de texte et met­tre [NOM_CLIENT], ain­si que [MOIS ANNEE].
    [NOM_CLIENT] sera rem­placé par le con­tenu d’une plage nom­mée “SyntheseClient_Nom_Client” dans votre fichier. 

N’hésitez pas à me don­ner vos com­men­taires pour des amélio­ra­tions ou des bugs potentiels.

A bien­tôt.

Pour marque-pages : Permaliens.

Laisser un commentaire

Votre adresse e-mail ne sera pas publiée.

Ce site utilise Akismet pour réduire les indésirables. En savoir plus sur comment les données de vos commentaires sont utilisées.