bonjour à tous
je vous livre aujourd'hui la derniere version de ma fonction multipage to one pdf
elle capture la fenêtre userform en naviguant sur les pages du Multipage
et les colle dans une feuille qui s'adapte toute seule ( zonne d'impression, saut de pages etc...)
de facon a ne sauver qu'une feuille avec toutes les page du Multipage dans le page respectives
vous avec la possibilité de choisir de ne garder que le multipage et donc de supprimer tout ce qui a autour
il y a utilisation des api compatible 32/64 bits
je met un fichier en exemple joint
je vous livre aujourd'hui la derniere version de ma fonction multipage to one pdf
elle capture la fenêtre userform en naviguant sur les pages du Multipage
et les colle dans une feuille qui s'adapte toute seule ( zonne d'impression, saut de pages etc...)
de facon a ne sauver qu'une feuille avec toutes les page du Multipage dans le page respectives
vous avec la possibilité de choisir de ne garder que le multipage et donc de supprimer tout ce qui a autour
il y a utilisation des api compatible 32/64 bits
je met un fichier en exemple joint
VB:
'**********************************************************************************
' __ _____ ___ . ___ _____ ___ ___
'|__| /\ | | | | | | / | | | | | | | | |\ |
'| /__\ | |--- | | |/\ | | | | | | | | | \ |
'| / \ | | \ | |___ | \ | |___| |___| |__ |___| | \|
'***********************************************************************************
'***************************************************************
' 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
