XL 2013 Impression d'un userform

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
P

PHV62

XLDnaute Junior
bonjour le forum
je souhaiterai imprimer un userform avec les informations dans les textbox et combobox grace a un bouton

merci d'avance pour votre aide
ph v
 
Trier par date Trier par votes
un exemple basé sur ma ressource similaire pour les ranges
imprimer un userform en pleine page quelque soit sa taille
dans un module standard
VB: 
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

et avec un bouton dans l'userform
VB: 
Private Sub CommandButton1_Click()
 ' Exemple impression directe
     ImprimerUserFormZoomé Me, , True

    ' Exemple export PDF 
    'Call ImprimerUserFormZoomé(UserForm1, "C:\Temp\Formulaire.pdf", False)
End Sub

edit j'ai remanier ça en fonction on imprime ou on sauve en pdf

la capture sera au max utilisable sur la feuille en gardant l'apect ratio intègre
voici ce que j'ai à l'ecran(ecran 107 cm) donc userform très grand
1753365916438.png


et voila comment il sortira à l'impression pdf ou autre
1753366049426.png

voila it's magic
Patrick
 
Dernière édition:
Vote positif 0 Vote négatif
Bonjour,
Voici ma version limitée à l'impression directe (pas sur fichier bien que ce soit facile à ajouter).
VB: 
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 Long)
#Else
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If

Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
Private Const KEYEVENTF_KEYUP = &H2

Sub PrintUserForm(UserForm As Object, _
                  Optional Margins As Boolean = True, _
                  Optional Preview As Boolean = True)
    Dim Workbook As Workbook
    Dim Shape As Shape
    Dim AvailableWidth As Double
    Dim AvailableHeight As Double
    Dim ShowMode As Integer
    Dim Address As String
    Dim Cell As Range
    '
    Const CorrectionZoom = 0.8
    
    'Check UserForm Show Mode
    ShowMode = UserFormShowMode(UserForm)
    
    'Copy UserForm (assumes Userform is the Foreground Window)
    Call AltPrintScreen
    
    'Hide vbModal UserForm to perform further actions
    If Not ShowMode = vbModeless Then
        UserForm.Hide
    End If
    
    'Create Temporary Workbook
    Application.Workbooks.Add
    
    'Paste the UserForm image to Temporary Workbook
    With ActiveSheet
        [A1].Select
        .Paste
        Set Shape = .Shapes(1)
        
        With .PageSetup
            If .PaperSize = xlPaperA4 Then
                If Shape.Height > Shape.Width Then
                    AvailableWidth = 21
                    AvailableHeight = 29.7
                    .Orientation = xlPortrait
                Else
                    AvailableWidth = 29.7
                    AvailableHeight = 21
                    .Orientation = xlLandscape
                End If
                
                If Not Margins Then
                    .LeftMargin = 0
                    .RightMargin = 0
                    .TopMargin = 0
                    .BottomMargin = 0
                    .HeaderMargin = 0
                    .FooterMargin = 0
                End If
                
                AvailableWidth = Application.CentimetersToPoints(AvailableWidth) - .LeftMargin - .RightMargin
                AvailableHeight = Application.CentimetersToPoints(AvailableWidth) - .HeaderMargin - .TopMargin - .FooterMargin - .BottomMargin
            Else
                MsgBox "Fonction PrintUserForm(): la taille de la feuille n'est pas prise en compte"
                Exit Sub
            End If
            
            'Correction Shape.BottomRightCell Column Width (can't get it by difference Shape.Width - BottomRightCell.Left !?)
            Set Cell = Shape.BottomRightCell
            Address = Cell.Address

            Do While Shape.BottomRightCell.Address = Address
                Cell.ColumnWidth = Cell.ColumnWidth - 1
            Loop
            Cell.ColumnWidth = Cell.ColumnWidth + 1
            
            'Print Area
            .PrintArea = "A1:" & Shape.BottomRightCell.Address(0, 0)
            .CenterHorizontally = True
            .CenterVertically = True
            .Zoom = Application.Min(AvailableWidth / Shape.Width, AvailableHeight / Shape.Height) * 100 * CorrectionZoom
        End With
        
        'Print
        .PrintOut Preview:=Preview
        
        'Close Temporary Workbook
        ActiveWorkbook.Close SaveChanges:=False
    End With
    
    'Show vbModal UserForm
    If Not ShowMode = vbModeless Then
        UserForm.Show
    End If
    
End Sub

'----------------------------
'Mode d'affichage du UserForm
'Return: vbModal (1)
'        vbModeless (0)
'        Erreur (Err.Number)
'----------------------------
Private Function UserFormShowMode(UserForm As Object) As Integer
    On Error Resume Next
    UserForm.Show vbModeless
    
    'Return Value
    If Err.Number = 401 Then
        UserFormShowMode = vbModal
    Else
        If Err.Number = 0 Then
            UserFormShowMode = vbModeless
        Else
            UserFormShowMode = Err.Number
        End If
    End If
    
    On Error GoTo 0
End Function

'------------------
'Capture the screen
'------------------
Sub PrintScreen()
    keybd_event VK_SNAPSHOT, 1, 0, 0
    DoEvents
End Sub

'-------------------------
'Capture the Active Window
'-------------------------
Sub AltPrintScreen()
    keybd_event VK_MENU, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
    keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
    DoEvents
End Sub

Et un fichier avec 3 UserForm de formes et tailles différentes imprimés en Preview seulement (pas d'impression réelle pour les tests)
 

Pièces jointes

Vote positif 0 Vote négatif
bonsoir dudu2
ceci ne pourra jamais être bon à 100%
VB: 
Do While Shape.BottomRightCell.Address = Address
                Cell.ColumnWidth = Cell.ColumnWidth - 1
            Loop
            Cell.ColumnWidth = Cell.ColumnWidth + 1


on voit bien la zone d'impression dans le classeur dynamique

1753575725970.png

voici comment ca sort
Capture1.JPG

avec ma methode
Capture2.JPG

et pour le gros userform
voici comme il sort avec ta metode
1753584168936.png

et avec ma methode
1753584232397.png

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, rh As Double
    Dim i As Long, vPB As VPageBreak
    Dim targetCol As Long, vpbCol As Long
    Dim pageBreakColAddress As String
    
    '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)
    Application.SendKeys "%{1068}"
    Application.SendKeys ""
    DoEvents
    
    uf.Hide
    
    ' Crée une nouvelle feuille
    Set ws = Sheets.Add
    ws.Range("A1").Select
    ws.Paste
    DoEvents
    Set shp = ws.Shapes(ws.Shapes.Count)
    
    ' Positionne sur A1
    shp.Top = 0
    shp.Left = 0
    
    ' Orientation
    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
    
    
    ' Calcule la zone initiale
    Set RnG = ws.Range("A1", shp.BottomRightCell)
    
    ' Recalcul du zoom
    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 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
        If ws.VPageBreaks.Count > 0 Then
            shp.Width = ws.VPageBreaks(1).Location.Left - 1 'on reduit la shapes au vpagebreaks(1)
            'ws.VPageBreaks(1).Delete 'ça marche jamais sur les vpagebreakautomatique
            'comme excel persite  a le recréer ce satane breakpage vertical su la derniere colonne
            'alors je reduit à zero la dernier colonne
            RnG.Columns(RnG.Columns.Count).ColumnWidth = 0
        End If
    End With
    
    ' Supprime PDF si présent
    If Not imprimer Then
        If Len(Dir(fichier)) > 0 Then Kill fichier
    End If
    
    ' Impression ou export
    If imprimer Then
        ws.PrintPreview 'ws.PrintOut
    Else
        ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fichier, Quality:=xlQualityStandard, OpenAfterPublish:=True
    End If
    
    ImprimerUserFormZoomé = True
    
finClean:
    Application.DisplayAlerts = False
    On Error Resume Next
    'ws.Delete
    Application.DisplayAlerts = True
    uf.Show
    Exit Function
    
finErr:
    MsgBox "Erreur pendant impression ou export", vbExclamation
    ImprimerUserFormZoomé = False
    Resume finClean
End Function
 
Vote positif 0 Vote négatif
Bonjour @patricktoulon,

Oui, je sais que la PrintArea n'est pas 100% sur l'image (je n'ai pas corrigé en lignes) du UserForm et surtout que ma correction de 0.8 sur le zoom est assez brutale mais j'ai fait l'impasse sur des calculs très précis en estimant que l'impression était satisfaisante.

D'ailleurs, la réduction de la dernière colonne par calcul a été impossible de manière totalement incompréhensible, d'où la boucle.
Ce calcul:
VB: 
Shape.BottomRightCell.ColumnWidth = Shape.Width - Shape.BottomRightCell.Left
donne un résultat totalement faux et je ne comprends pas pourquoi tellement ça parait simple.
 
Vote positif 0 Vote négatif
D'ailleurs, je n'avais pas remarqué à quel point nos codes sont similaires.
Edit: Sauf le re-Show du UserForm que tu fais systématiquement en vbModal ne sachant pas quel mode a été initialement utilisé pour le UserForm

Mais vraiment cette histoire de calcul de largeur me perturbe. Si tu trouves une explication...
Je pense qu'Excel nous enfume sur le Shape.Width et Shape.Height. D'où la correction nécessaire sur le Zoom.
 
Dernière édition:
Vote positif 0 Vote négatif
re
Je pense qu'Excel nous enfume sur le Shape.Width et Shape.Height. D'où la correction nécessaire sur le Zoom.
Cliquez pour agrandir...
non cest pas tout fait ca
oui l'erreur de largeur est du au fait que a partir du moment ou tu change quelque chose dans le pagesetup excel recalcule automatiquement la largeur de page c'est pour ca que je le fait a la fin le retrait et la réduction
impossible de faire autrement
par contre quand il y en a plusieurs de saut de page la oui on peut les supprimer c'est bizarre je sais
tu trouvera dans les truc et actuces la version pour les plages
de cellules

démonstration pour ce saut de page vertical insupprimable
le code a l'origine avec la suppression des sauts de pages
comme tu va le voir le vpagebreaks() ne peut pas être supprimé
et c'est pas peine d'essayer avec mon code original
demo3.gif

le code issue de ma version original
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.95
    Dim wRatio As Double, hRatio As Double, dw As Double, rh 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
    Do While ws.Shapes.Count = 0
        On Error Resume Next
        ws.Paste
        Err.Clear
    Loop
    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
        rh = shp.Height / .Height
        .ColumnWidth = .ColumnWidth * dw
        .RowHeight = .RowHeight * (rh)
    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
   
     On Error Resume Next
    ' Celui-là est parfois résiduel
    If RnG.Parent.VPageBreaks.Count > 0 Then RnG.Parent.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    If RnG.Parent.HPageBreaks.Count > 0 Then RnG.Parent.HPageBreaks(1).DragOff Direction:=xlDown, RegionIndex:=1
   
    Dim i As Long
    For i = RnG.Parent.HPageBreaks.Count To 1 Step -1
        RnG.Parent.HPageBreaks(i).Delete
    Next
    For i = RnG.Parent.VPageBreaks.Count To 1 Step -1
        RnG.Parent.VPageBreaks(i).Delete
    Next
    On Error GoTo 0
   
     ActiveWindow.View = xlPageBreakPreview
      shp.Top = 50
    Exit Function
   
   
   
    ' 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.PrintPreview '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

c'est pour çà que je triche dans mon exemple précédent
je ramène la largeur de la capture au premier vpagebreak et je réduis la dernière colonne
 
Vote positif 0 Vote négatif
J'ai compris... La confusion vient du fait que Range.ColumnWidth est exprimé dans une unité à la mors moi-le-nez et pas en Points contrairement à Range.Width. Ahhhhhh purée, que de temps perdu à cause de cette daube d'unité.
 
Vote positif 0 Vote négatif
re
en fait voila comment je rattrape
je remplace la méthode logique par la méthode de rattrapage
VB: 
On Error Resume Next
    'méthode logique
    'Dim i As Long
    'For i = RnG.Parent.HPageBreaks.Count To 1 Step -1
    'RnG.Parent.HPageBreaks(i).Delete
    'Next
    'For i = RnG.Parent.VPageBreaks.Count To 1 Step -1
    'RnG.Parent.VPageBreaks(i).Delete
    'Next
    ' Celui-là est parfois résiduel
    'If RnG.Parent.VPageBreaks.Count > 0 Then RnG.Parent.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    'If RnG.Parent.HPageBreaks.Count > 0 Then RnG.Parent.HPageBreaks(1).DragOff Direction:=xlDown, RegionIndex:=1
    '--------------------------------------------------------------------------------
    'methode  de rattrapage
    If RnG.Parent.VPageBreaks.Count > 0 Then 'SI IL RESTE LE SAUT DE PAGE
        shp.Width = ws.VPageBreaks(1).Location.Left ''on reduit a la largeur du saut de page vertical
        RnG.Columns(RnG.Columns.Count).ColumnWidth = 0 ''on reduit donc aussi la derniere colonne a zero  de large
        'comme on a reduit la largeur de la shape
        'et qu'elle est en lokaspect ratio true ,la hauteur a diminuée aussi
        'on reduit donc la hauteur de la plage
        Set RnG = ws.Range("a1", Cells(shp.BottomRightCell.Row, RnG.Columns.Count)) '
        ws.PageSetup.PrintArea = RnG.Address 'on remet l'adress de la plage dans le print area
    End If
    
    On Error GoTo 0


resultat on a le print area le plus près possible

démo avec le petit userform

demo3.gif


et avec le gros userform


demo3.gif


Nb :
je pourrais recalculer le zoom pour être au plus près si on voulait faire les choses entièrement
 
Vote positif 0 Vote négatif
Je ne trouve pas de pas de PageBreaks dans la feuille de travail.
Le recadrage de la PrintArea est en effet utile pour être au plus juste sur la Shape.
Par contre le centrage final n'est pas parfait soit en largeur (xlLandScape) soit en hauteur (xlPortrait) car on prend le minimum du Zoom possible des 2 dimensions. Il faudrait jouer avec une colonne à gauche et un ligne en haut pour ajuster mais ça devient compliqué pour pas grand chose.

Par contre je ne comprends pas du tout cette correction de Zoom que j'ai prise à ta valeur (0.88).
 

Pièces jointes

Vote positif 0 Vote négatif
zoom 100 de excel=88% zoom window
tu le constatera partout
le zoom excel n'est qu'une vue de l'esprit ou une échelle si tu préfère et qui lui est propre
c'est ce satané converteur twip qui pose des soucis depuis Window NT
je suis en train de faire des tests en prenant le truc à l'envers

à savoir
prendre une plage harbitraire au moins 5/6 colonne et 15 lignes
la redimensionner au prorata de centimeterstopoints du format A4
coller la capture
redimensionner la capture au left du premier vpagesbreak si existe

voila on supprime la notion de zoom de l’équation
puisque la plage est sensé être dimensionné a 29.7*21 ou l'inverse (ou plus) et en point bien évidemment
VB: 
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'Fonction pour imprimer ou exporter la capture d'un userform en pleine page
'quelque soit sa taille
'auteur: patricktoulon
'version beta SANS ZOOM!!!!!
#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 Long)
#Else
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If

Sub snapshotForm()
    keybd_event &H12, 0, 0, 0
    keybd_event &H2C, 0, 0, 0
    keybd_event &H2C, 0, &H2, 0
    keybd_event &H12, 0, &H2, 0
    DoEvents
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, rh As Double
    
    
    ' 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
    
    ' Nouvelle feuille temporaire
    Set ws = Sheets.Add
    
    Set RnG = ws.[a1:g20]
    ws.PageSetup.PrintArea = RnG.Address
    
    ' ws.[a1] = "a"
    
    ' Orientation & dimensions papier
    If uf.Width > uf.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
    
    wRatio = RnG.Width / width_papier
    hRatio = RnG.Height / height_papier
    RnG.ColumnWidth = RnG.ColumnWidth / wRatio
    RnG.RowHeight = RnG.RowHeight / hRatio
    
    ' Capture de l'écran active (le UserForm)
    snapshotForm
    
    ' Cache le formulaire
    uf.Hide
    DoEvents
    
    Do While ws.Shapes.Count = 0
        On Error Resume Next
        ws.Paste
        Err.Clear
    Loop
    Set shp = ws.Shapes(ws.Shapes.Count)
    With ws.PageSetup
        '.FitToPagesWide = 1
        '.FitToPagesTall = 1
        .LeftMargin = 0
        .RightMargin = 0
        .TopMargin = 0
        .BottomMargin = 0
        .HeaderMargin = 0
        .FooterMargin = 0
        .CenterHorizontally = True
        .CenterVertically = True
    End With
    
    ' Aligne l’image sur A1
    shp.Top = 0
    shp.Left = 0
    wRatio = width_papier / RnG.Width
    hRatio = height_papier / RnG.Height
    RnG.ColumnWidth = RnG.ColumnWidth / wRatio
    RnG.RowHeight = RnG.RowHeight / hRatio
    'shp.Width = RnG.Width
    DoEvents
    
    If ws.VPageBreaks.Count > 0 Then
        RnG.Columns(RnG.Columns.Count).ColumnWidth = 0.1
        shp.Width = RnG.Width
        shp.Width = ws.VPageBreaks(1).Location.Left
        If shp.Height > RnG.Height Then shp.Height = RnG.Height
        shp.Top = (RnG.Height - shp.Height) / 2
        shp.Left = (RnG.Width - shp.Width) / 2
    End If
    
    
    '  reste a re inclure ici la selection imprimante pdf en mode window ou l'export
    
    ws.PrintPreview
    
    'ws.PrintOut From:=1, To:=1'on imprime que la page 1 il peut y avoir une page2 vide
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
    
    
End Function
les 3 exemple dans ce fichier fonctionnent un carré et deux rectangles grands ou larges
autrement dit les 3 possibilités
 

Pièces jointes

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Yann71
  • Question Question
Microsoft 365 Impression recto-verso
Réponses
2
Affichages
92
Yann71
Yann71
J
  • Question Question
Microsoft 365 Sélectionner plage nommée via un comboBox
Réponses
3
Affichages
306
fanfan38
fanfan38
Agecanonix35400
  • Question Question
XL 2016 *** RESOLU MERCI :)*** Impression personnalisée.
2 3
Réponses
35
Affichages
486
TooFatBoy
TooFatBoy
M
  • Résolu(e)
Microsoft 365 Impression Userform en format paysage + Envoyer l'imprime écran du Userform par courriel
2
Réponses
17
Affichages
852
patricktoulon
patricktoulon
sousou
  • Question Question
XL 2010 gestion userform
Réponses
1
Affichages
252
Dranreb
Dranreb
patricktoulon
Exporter en pdf ou imprimer un userform en mode photo
Réponses
0
Affichages
103
patricktoulon
patricktoulon
D
  • Question Question
XL 2019 User Form
Réponses
9
Affichages
357
Debie
D
J
  • Question Question
Microsoft 365 affichage userform
Réponses
4
Affichages
407
TooFatBoy
TooFatBoy
C
  • Résolu(e)
XL 2021 Userform impression + choix des feuilles
Réponses
8
Affichages
465
candido57
C
Twing83
  • Résolu(e)
XL 2010 Travail base de données et UserForm
2 3
Réponses
40
Affichages
1 K
ChTi160
ChTi160
U
  • Question Question
Autres je n'arrive pas à récupérer mon userform pour l'afficher
Réponses
3
Affichages
153
un internaute
U
K
  • Question Question
XL 2016 Modification dans userform et sheet
Réponses
13
Affichages
310
Valtrase
Valtrase
patricktoulon
Capturer et imprimer ou exporter en pdf un userform
Réponses
4
Affichages
381
PHV62
P
M
  • Résolu(e)
Microsoft 365 VBA Bon de commande Combo et Textbox Problème
Réponses
1
Affichages
139
vgendron
vgendron
A
  • Question Question
Microsoft 365 UserForm Modal et non Modal
Réponses
2
Affichages
343
Dranreb
Dranreb
D
  • Résolu(e)
XL 2016 Filtrage ListBox d'un userform
Réponses
6
Affichages
108
dgil37
D
jcf6464
  • Résolu(e)
Microsoft 365 Saisie d'un userform vers listes
Réponses
10
Affichages
180
jcf6464
jcf6464
natorp
  • Résolu(e)
XL 2019 Un seul Bouton Option actif
Réponses
8
Affichages
109
cathodique
cathodique
jcf6464
  • Résolu(e)
Microsoft 365 Userform Filtres ne fonctionne pas
2 3 4
Réponses
46
Affichages
1 K
jcf6464
jcf6464
A
  • Question Question
Microsoft 365 problème de remplissage de listbox
Réponses
8
Affichages
313
job75
job75
Retour