Imprimer ou exporte une plage en pdf pleine page zoom auto

[patricktoulon]

Bonjour à tous
comme une demande a été faite récemment je me permet de le mettre ici dans les astuces
en effet imprimer une plage pleine page c'est facile avec fittopage quand elle est plus grande
mais quand elle est plus petite ,FitToPage sur le page setup n'a aucun effet
il faut zoomer
oui mais combien le zoom
je vous propose ici de faire les chose automatiquement
l'orientat ion(landscape ou portrait)--> automatique
calcul du zoom --> automatique
suppression des eventuels saut de page verticaux et horizontaux --> automatique
bref tout totomatiC


fonction:

'************************************************
'Categorie divers
'impression range  pdf (full page[zoom auto])
'auteur :patricktoulon
'Version 1.1
'************************************************


Function PrintPdfFitpage(RnG As Range, lFichier As String)
   
     Dim hRatio As Double, wRatio As Double, Zoom As Long
   
    'coeff marge securité  concernant le zoom
    'car excel même si on enleve tout ne commence par l'impression a zero des bords de feuille
    '+ eventuellement les marge pour les même raison dans les paramètres windows de l'imprimante
    Const margeSecurite As Double = 0.9   ' marge de sécurité 1%
   
    With RnG.Parent
        'la plage a imprimer
        .PageSetup.PrintArea = RnG.Address
       
        'on fait tout peter les saut de pages
        .ResetAllPageBreaks
        'le premier vpagebreak original est toujours difficile a supprimer (un bug dans excel sans gravité)
        'on le supprime donc
        If .VPageBreaks.Count > 1 Then .VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
       
        ' Supprimer tous les sauts de page horizontaux et verticaux
        Do While .HPageBreaks.Count > 0
            .HPageBreaks.Remove 1
        Loop
        Do While .VPageBreaks.Count > 0
            .VPageBreaks.Remove 1
        Loop
       
        With .PageSetup
            ' on fait peter les header et footer de page
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = ""
           
            ' on fait peter les marges
            .TopMargin = 0
            .BottomMargin = 0
            .LeftMargin = 0
            .RightMargin = 0
            .HeaderMargin = 0
            .FooterMargin = 0
           
            ' Désactiver éléments visuels
            .CenterHorizontally = True
            .CenterVertically = True
            .PrintGridlines = False
            .PrintHeadings = False
            .PrintComments = xlPrintNoComments
           
            'on determine ici le landscape ou protrait et par la même ocasion les largeuret hauteur de papier
            'et les  Dimensions de la feuille papier en points!!!!
            Dim width_papier As Double, height_papier As Double
            If RnG.Width > RnG.Height Then
                width_papier = Application.CentimetersToPoints(29.7)
                height_papier = Application.CentimetersToPoints(21)
                .Orientation = xlLandscape
            Else
                width_papier = Application.CentimetersToPoints(21)
                height_papier = Application.CentimetersToPoints(29.7)
                .Orientation = xlPortrait
            End If
           
            'on fait les ratios des largeur et hauteur par rapport a la plage a imprimer
            wRatio = width_papier / RnG.Width
            hRatio = height_papier / RnG.Height
            'et on garde l'entier du min des deux
            Zoom = Int(Application.Min(wRatio, hRatio) * 100 * margeSecurite) 'le zoom*le coeff de securité
           
            ' on ne peut pas aller plus loin que 400% en zoom dans excel alors on impose la limite
            If Zoom > 400 Then Zoom = 400
            If Zoom < 10 Then Zoom = 10
           
            .Zoom = Zoom 'on applique le zoom calculer à l'entier près
        End With
       
        ' on ecrase le fichier existant
        If Len(Dir(lFichier)) > 0 Then Kill lFichier
       
        ' amis du soir  bonsoir c'est dans la boite
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=lFichier, Quality:=xlQualityStandard, OpenAfterPublish:=True
    End With
   
End Function

deux sub de test avec plage et apect ratio et orientation différente

Sub test1()
    Dim RnG As Range, fichier As String
    fichier = CreateObject("wscript.shell").specialfolders("desktop") & "\ma plage1.pdf"
    Set RnG = Worksheets("Envoi").Range("C24:I37")
    PrintPdfFitpage RnG, fichier
End Sub

Sub test2()
    Dim RnG As Range, fichier As String
    fichier = CreateObject("wscript.shell").specialfolders("desktop") & "\ma plage2.pdf"
    Set RnG = Worksheets("Envoi").Range("M21:O37")
    PrintPdfFitpage RnG, fichier
End Sub

voila résultat garanti; la plage imprimé en pdf prendra toute la place possible dans la pape sans être déformée
patrick