Imprimer shape Image en format et dimension A4

Version imprimable

17/05/2017, 21h25
sormick

Imprimer shape Image en format et dimension A4
Bonjour,
J'ai inséré une Image JPG sur Excel et je souhaiterais via VBA l'imprimer en format et dimension A4 mais malheureusement je ne sais pas comment faire car la fonction printout ne fonctionne pas sur cette macro et lorsque j'y arrive avec d'autres macros l'image n'est pas bien redimensionnée en Format A4.
Voici ce que j'ai:
Code:

1 2 3 4 5 6 Dim Img As Object Sheets("feuil1").Select For Each Img In Worksheets("feuil1").Shapes Img.Select Next selection.printout

Salut, te renseigner sur CentimetersToPoints
puis via qqch comme

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
.....
Coeff = 29.7 / 21
W = Application.CentimetersToPoints(29.7)
H = W * Coeff
 
With ActiveSheet.Shapes(Tablo(i))
    .Left = L
    .Top = T
    .Width = W
    .Height = H
End With
 
.....

où Tablo est rempli via ceci

Code:

1
2
3
4
5
6
7
Erase Tablo
For Each oOle In Worksheets(ActiveSheet.Name).OLEObjects
    sNomOle = ActiveSheet.Shapes(oOle.Name).Name
    ReDim Preserve Tablo(i)
    Tablo(i) = sNomOle
    i = i + 1
Next oOle

Un A4 imprimé à 300 dpi fait au départ 2480 x 3508 pixels

18/05/2017, 16h45
sormick

Merci

Merci beaucoup !
Excellente journée a vous tous !

Code:

1
2
3
sub test()
ImprimeGrandFormat sheest(X),Shapes(Y)
end sub

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub ImprimeGrandFormat(Wsh As Worksheet, Shp As Shape)
    Dim w
    With Wsh
        With .PageSetup
            .TopMargin = 0
            .LeftMargin = 0
            .RightMargin = 0
            .BottomMargin = 0
            .FooterMargin = 0
            .HeaderMargin = 0
            .CenterHorizontally = True
            .CenterVertically = True
            .Orientation = IIf(Shp.Width > Shp.Height, 2, 1)
        End With
        With Shp
             t=.top :l=.left: w = .Width
            If .Width < .Height Then
                .Height = Application.CentimetersToPoints(29.7)
            Else
                .Width = Application.CentimetersToPoints(21)
            End If
            .Top = 0
            .Left = 0
        End With
        With .PageSetup
            If Shp.Width < Shp.Height Then
                .FitToPagesTall = 1
                '.FitToPagesWide = 1
            Else
                '.FitToPagesTall = 1
                .FitToPagesWide = 1
            End If
        End With
    End With
    Wsh.PrintPreview
    Shp.Width = w:shp.left=l:shp.top=t
End Sub