Discussion :

[joums]

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

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

Merci
Voici le code que j'utilise

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[mayekeul]

bonjour,

en faisant un truc plus de ce genre ???

ça dis quoi??

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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

[joums]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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