Convertir selection en jpeg

Version imprimable

Bonjour,
Je souhaiterais convertir une sélection contenant plusieurs shapes et cellules (qui se trouve dans la même feuille) en 1 seule image (Jpeg) qui sera un fichier à part.

J'ai commencé une macro avec la fonction copypicture mais cela ne marche pas complétement.
Bizarrement la copie ne s'effectue pas sur la totalité de la sélection demandée :calim2:

Pour quelles raisons ? avec vous une idée pour m'aider à résoudre se problème.

Merci
Voici le code que j'utilise
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 'Création de l'image Dim img1 As Range 'déclare la variable imag (Image) Dim img2 As Range 'déclare la variable imag (Image) Set img1 = Sheets("Feuil1").Range("A1:B15") Set img2 = Sheets("Feuil1").Range("A20") 'img1.Copy img2 'copie la plage et la colle dans dest img1.Select Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture img2.Select Me.Paste ThisWorkbook.Names.Add "Image", Selection.Name 'mémorise dans le nom défini Image ActiveCell.Activate Dim Pict As Object On Error Resume Next Set Pict = Me.Pictures([Image]) Application.ScreenUpdating = False Pict.Name = Range("F2").Value Pict.CopyPicture 'copie la dernière image créée With Me.ChartObjects.Add(0, 0, Pict.Width, Pict.Height).Chart .Paste 'colle l'image dans un graphique temporaire .Export "D:\" & Pict.Name & ".jpg", "JPG" .Parent.Delete 'Supprime le graphique End With

bonjour,

en faisant un truc plus de ce genre ???

ça dis quoi??

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub test()
'Création de l'image
Dim RngImg As Range 'déclare la variable imag (Image)
Dim img2 As Range 'déclare la variable imag (Image)
Dim Ch As Chart
Dim Im As Picture
 
Set RngImg = Range("A1:I23")
Set Ch = Charts.Add
 
'copier image
RngImg.CopyPicture xlScreen, xlPicture
 
'coller dans chart
Ch.Paste
 
'export vers jpeg
Ch.Export "H:\DATA\Test.jpg"
 
End Sub

12/07/2010, 11h55
joums

Merci pour votre aide,
le code fonctionne, seulement il faudrait que je l'améliore sur plusieurs points :
- l'image donné est déformé par rapport à ce qu'on voit sur excel
- un onglet graph se crée, il faudrait le supprimer

Tout est ok
MERCI à tous,
voici le code si ca peut intéresser

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
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Private Sub CommandButton3_Click()
'Création de l'image
Dim RngImg As Range 'déclare la variable imag (Image)
Dim Ch As Chart
Dim Im As Picture
Dim A As Range
 
 
 
 
Set A = Sheets("Feuil1").Range("B4")
 
 
Set RngImg = Range("A1:B15")
Set Ch = Charts.Add
 
Ch.Name = Sheets("Feuil1").Range("B9").Value
'copier image
RngImg.CopyPicture xlScreen, xlPicture
 
 
'coller dans chart
Ch.Paste
 Application.ScreenUpdating = False
    With ActiveChart.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.17)
        .RightMargin = Application.InchesToPoints(0.19)
        .TopMargin = Application.InchesToPoints(0.33)
        .BottomMargin = Application.InchesToPoints(0.35)
        .HeaderMargin = Application.InchesToPoints(0.26)
        .FooterMargin = Application.InchesToPoints(0.19)
        .ChartSize = xlFullPage
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .BlackAndWhite = False
        .Zoom = 100
    End With
     Application.ScreenUpdating = True
 
 
'export vers jpeg
Ch.Export "D:\" & A & "\" & Ch.Name & ".jpg", "JPG"
 
Application.DisplayAlerts = False
    Ch.Delete 'Supprime le graphique
 
End Sub