patricktoulon
XLDnaute Barbatruc
Bonjour a tous
la petite sœur de cette astuce
ici on va capturer le userform et l'imprimer ou l'exporter en pdf en pleine page
quelque soit la taille de l'userform comme sa petite soeur le zoom augmenter ou réducteur est automatique en fonction du format A4
en effet la fonction native printForm impose une limite de taille
donc pour imprimer pleine page quelque soit la taille il faut astuce
Patrick
la petite sœur de cette astuce
ici on va capturer le userform et l'imprimer ou l'exporter en pdf en pleine page
quelque soit la taille de l'userform comme sa petite soeur le zoom augmenter ou réducteur est automatique en fonction du format A4
en effet la fonction native printForm impose une limite de taille
donc pour imprimer pleine page quelque soit la taille il faut astuce
VB:
'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'Fonction pour imprimer ou exporter la capture d'un userform en pleine page
'quelque soit sa taille
'auteur: patricktoulon
'version : 1.2
'date version 23/07/2025
'cette fonction est faite pour palier au problème
'des userforms en grande taille (la fonction printForm imposant une limite de taille)
'*************************************************
'exemple d 'appel dans un userform a l'aide d'un bouton
''Un bouton dans le userform
'Private Sub CommandButton1_Click()
' Exemple impression directe
'ImprimerUserFormZoomé Me, , True
' Exemple export PDF sur le bureau
'Call ImprimerUserFormZoomé(UserForm1, "C:\Temp\Formulaire.pdf", False)
'End Sub
'**************************************************
Public Function ImprimerUserFormZoomé(uf As Object, Optional nomFichierPDF As String = "", Optional imprimer As Boolean = False) As Boolean
Dim fichier As String, ws As Worksheet
Dim shp As Shape, RnG As Range
Dim Zoom As Long, width_papier As Double, height_papier As Double
Const margeSecurite As Double = 0.88
Dim wRatio As Double, hRatio As Double, dw As Double
On Error GoTo finErr
' Détermine le chemin du PDF si non fourni
If nomFichierPDF = "" Then
fichier = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\UserFormCapture.pdf"
Else
fichier = nomFichierPDF
End If
' Capture de l'écran active (le UserForm)
'uf.SetFocus'n'existe pas en vba
Application.SendKeys "%{1068}"
Application.SendKeys ""
DoEvents
Application.SendKeys "{NUMLOCK}"
DoEvents
' Cache le formulaire
uf.Hide
' Nouvelle feuille temporaire
Set ws = Sheets.Add
ws.Range("A1").Select
ws.Paste
Set shp = ws.Shapes(ws.Shapes.Count)
' Aligne l’image sur A1
shp.Top = ws.Range("A1").Top
shp.Left = ws.Range("A1").Left
' Calcule la plage couverte
Set RnG = ws.Range("A1", shp.BottomRightCell)
' Corrige largeur colonne pour adapter à la taille du Shape
With RnG
dw = shp.Width / .Width
.ColumnWidth = .ColumnWidth * dw
End With
' Orientation & dimensions papier
If shp.Width > shp.Height Then
ws.PageSetup.Orientation = xlLandscape
width_papier = Application.CentimetersToPoints(29.7)
height_papier = Application.CentimetersToPoints(21)
Else
ws.PageSetup.Orientation = xlPortrait
width_papier = Application.CentimetersToPoints(21)
height_papier = Application.CentimetersToPoints(29.7)
End If
' Calcul du Zoom à appliquer
wRatio = width_papier / shp.Width
hRatio = height_papier / shp.Height
Zoom = Int(Application.Min(wRatio, hRatio) * 100 * margeSecurite)
If Zoom > 400 Then Zoom = 400
If Zoom < 10 Then Zoom = 10
' Configuration de l'impression
With ws.PageSetup
.PrintArea = RnG.Address
.Zoom = Zoom
.LeftMargin = 0
.RightMargin = 0
.TopMargin = 0
.BottomMargin = 0
.HeaderMargin = 0
.FooterMargin = 0
.CenterHorizontally = True
.CenterVertically = True
End With
' Supprime PDF existant si présent
If Not imprimer Then
If Len(Dir(fichier)) > 0 Then Kill fichier
End If
' Impression ou export
If imprimer Then
ws.PrintOut
Else
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fichier, Quality:=xlQualityStandard, OpenAfterPublish:=True
End If
ImprimerUserFormZoomé = True
finClean:
' Nettoyage
Application.DisplayAlerts = False
On Error Resume Next
ws.Delete
Application.DisplayAlerts = True
uf.Show
Exit Function
finErr:
MsgBox "Une erreur est survenue pendant l'impression ou l'export du UserForm.", vbExclamation
ImprimerUserFormZoomé = False
Resume finClean
End Function
