Enregistrer les pages d'un multipage dans un même PDF 1.3

'**********************************************************************************
' __        _____  ___   .  ___         _____  ___             ___
'|__|  /\     |   |   |  | |     | /      |   |   | |   | |   |   | |\  |
'|    /__\    |   |---   | |     |/\      |   |   | |   | |   |   | | \ |
'|   /    \   |   |   \  | |___  |  \     |   |___| |___| |__ |___| |  \|

'***********************************************************************************
'***************************************************************
'                         ENREGISTRER LES PAGES D 'UN MULTIPAGE EN PDF
' auteur: patricktoulon
' version 1.3
' Date Version:17/11/2022
' gestion des latences d'accès au clipboard améliorées et plus sur !!
' le clipboard est vidé a chaque capture
' on évite ainsi d'avoir 2 fois la même image sur deux pages
' les captures sont centrées sur les pages

' mises à jour
' version1.3
' ajout de la fonction CropsImage pour de garder que le multipage dans la capture

'**************************************************************
Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Dim handle As LongPtr
#Else
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32.dll" () As Long
    Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
    Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
    Dim handle As Long
#End If

Const VK_SNAPSHOT = 44
Const KEYEVENTF_KEYUP = 2
Const KEYEVENTF_EXTENDEDKEY = 1

Sub MultiPageToPdF(Multip As MSForms.MultiPage, Optional ByVal OnlyControl As Boolean = False)
    Dim cel As Range, I&, R As Range, iTop&, x&, a, HpB, VpB, chemin$, q#, CrPs
    Multip.SetFocus
    handle = GetActiveWindow
    BringWindowToTop handle
    OpenClipboard 0&: EmptyClipboard: CloseClipboard
    With Sheets.Add(after:=Sheets(Sheets.Count))
        .PageSetup.PrintArea = Range("A:A").Resize(, Multip.Parent.Width / .Range("A1").Width)
        Sheets(1).Activate
        Set cel = .Range("A1")
        iTop = 0
        Multip.Value = 0
        For I = 0 To Multip.Pages.Count - 1
            Multip.Value = I

            'les gestions d'attente avec wait ou sleep ou toute autres fonction de temporisation
            'sont trop aléatoires en fonction de la puissance du pc et de l'uc et ou memoire utilisée
            'et des latence d'accès au clipboard avec les versions actuelles d'excel qui on largement augmenté depuis  2013
            'j'utilise donc l'api IsClipboardFormatAvailable dans un looping
            ' avec cela je n'attent pas plus ni moins longtemps qu'il le faut
            'ici on vide le clipboard avec gestion d'attente que ce soit finidonc l'api doit me retourner "0"
            OpenClipboard 0&:
            Do While IsClipboardFormatAvailable(2) = 1
                EmptyClipboard
                DoEvents
                CloseClipboard
            Loop

            'on lance la touche capture
            x = capture


            'ici gestion d'attente d'un handle bitmap dans le clipboard donc l'api doit me retourner "1"
            ' avec un decompte de la variable timer "Q" à  chaque tour jusqu'a 2 secondes
            'pour pouvoir sortir le cas échéant si la capture n'a pas été effectuée
            q = Timer
            Do While IsClipboardFormatAvailable(2) = 0
                DoEvents

                If Timer - q > 2 Then x = False: MsgBox "durée d'attente trop longue": Exit Do
            Loop


            'on sort si il y a eu un soucis de capture
            If Not x Then
                Application.DisplayAlerts = False
                .Delete
                Application.DisplayAlerts = True
                Exit Sub
            End If


            If x Then    'si x est true alors la capture est effective

                .Pictures.Paste    'on colle alors la capture dans la feuille
              If OnlyControl Then CrPs = cropsimage(Multip, .Shapes(.Shapes.Count))
                With .Shapes(.Shapes.Count)    'on place l'image  itop est incrémenté avec la bottomrightcell.top
                    .Left = 0
                    .Top = iTop
                    Set cel = .BottomRightCell.Offset(2, 2)
                    Set R = .Parent.Range(.TopLeftCell, .BottomRightCell)
                    .Left = (R.Width - .Width) / 2    'on centre horizontalement la capture dans la page
                End With
                iTop = cel.Top

                'on ajoute les sauts de page
                'il sont positionnés en fonction de la variable cel
                .HPageBreaks.Add Before:=cel.Offset(-1)
                .VPageBreaks.Add Before:=cel.Offset(, -1)
            End If
            Application.CutCopyMode = False    'm'oouuuais pas trop efficace ça
        Next

        With .PageSetup    'parametre de mise en page
            .PrintHeadings = False: .PrintGridlines = False: .CenterHorizontally = True
            .CenterVertically = True: .Orientation = xlLandscape: .LeftMargin = 0
            .RightMargin = 0: .TopMargin = 0: .BottomMargin = 0
        End With

        OpenClipboard 0&: EmptyClipboard: CloseClipboard    'vide le clipboard



        chemin = ThisWorkbook.Path & "\Multipage capture.pdf'"

        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin, Quality:=xlQualityStandard _
                           , IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True

        MsgBox "le multipage  a été enregistré en pdf "

    End With
End Sub

Function capture()
    BringWindowToTop handle
    keybd_event VK_SNAPSHOT, 1, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 1, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
    capture = True
End Function

Function cropsimage(Multip, shap)
 Dim EcX, EcY
 With Multip.Parent
        EcX = .Width - .InsideWidth
        EcY = .Height - .InsideHeight
    End With
    With shap 'Selection.ShapeRange
        .PictureFormat.CropLeft = Multip.Left + EcX
        .PictureFormat.CropTop = Multip.Top + EcY
        .PictureFormat.CropRight = Multip.Parent.InsideWidth - (Multip.Left + Multip.Width) + EcX
        .PictureFormat.CropBottom = Multip.Parent.InsideHeight - (Multip.Top + Multip.Height) + EcX
    End With
cropsimage = True
End Function