[E-07] amélioration code capture image feuille

Version imprimable

Bonjour à tou(te)s,

Cette nuit, j'ai concrétiser un code pour mes besoins propres, comme je l'ai enregistré en XLAM (excel 2007), je l'édite pour savoir si des améliorations peuvent être apportées,

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
Sub CAPTURE_FEUILLE()
Dim mes As Range, monImage As String, Sh As Shape, m As String
m = InputBox("NOM DE L'IMAGE", "DEFINIR UN NOM")
If m = "" Then: Exit Sub 'si l'operation est annulée
Set mes = Application.InputBox("Choix de cellule(s)", Type:=8)
 
    monImage = mes.Address
    Range(monImage).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Sheets("Feuil1").Select
    ActiveSheet.Paste
  'Récupère la dernière forme de la feuille
    Set Sh = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    'Définit le nom et le lieu de stockage de l'image
 
    monImage = "C:\Users\Dominique\Pictures\" & m & ".jpg"
 
    'Colle l'image dans un graphique
    With ActiveSheet.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
        .Paste
        'Sauvegarde l'image du graphique au format jpg
        .Export monImage, "JPG"
    End With
 
    'Supprime le graphique et la forme.
    With ActiveSheet
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
        .Shapes(ActiveSheet.Shapes.Count).Delete
    End With
 
End Sub

Merci d'avance

Salut
Voila quelques modifs

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
Sub CAPTURE_FEUILLE()
Dim mes As Range, monImage As String, Sh As Shape, m As String
m = InputBox("NOM DE L'IMAGE", "DEFINIR UN NOM")
If m = "" Then: Exit Sub 'si l'operation est annulée
Set mes = Application.InputBox("Choix de cellule(s)", Type:=8)
 
    'monImage = mes.Address
    'Range(monImage).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    mes.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    'Sheets("Feuil1").Select
    'ActiveSheet.Paste
    With Sheets("Feuil1")
        'Sheets("Feuil1").Paste
        .Paste
        'Récupère la dernière forme de la feuille
        'Set Sh = ActiveSheet..Shapes(ActiveSheet..Shapes.Count)
        Set Sh = .Shapes(.Shapes.Count)
        'Définit le nom et le lieu de stockage de l'image
        monImage = "C:\Users\Dominique\Pictures\" & m & ".jpg"
 
        'Colle l'image dans un graphique
        With .ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
            '.Paste
            .Chart.Paste ' pour eviter les probleme lié a l'imbrication de with, normalement ca n'est pas utili mais bon paste etant valable pour chart comme opur sheets("feuil1")
            'Sauvegarde l'image du graphique au format jpg
            '.Export monImage, "JPG"
            .Chart.Export monImage, "JPG"
        End With
 
        'Supprime le graphique et la forme.
        '.ChartObjects(ActiveSheet.ChartObjects.Count).Delete
        '.Shapes(ActiveSheet.Shapes.Count).Delete
        .ChartObjects(.ChartObjects.Count).Delete
        .Shapes(.Shapes.Count).Delete
 
    End With
 
End Sub

A++
Qwaz

20/03/2009, 21h52
casefayere

Je viens de regarder, me suis rendu compte que tu l'avais bien allégé.

Quant à la ligne :

Code:

If Error = "424" Then Exit Sub

je croyais déjà l'avoir supprimée, c'est vrai qu'elle ne servait à rien

Merci encore
20/03/2009, 22h04
Qwazerty

Salut
Je n'ai et ne vois toujours pas pas cette ligne dans ton code :), toi tu es fatigué ^^.
a++
Qwaz
20/03/2009, 22h09
casefayere

C'est parce que j'ai comparé avec la macro que j'avais gardé mais je n'ai pas du enregistré quand j'ai enlevé cette ligne,

J'aurai pas du le dire, ça faisait une bétise de moins :yaisse2:

Mais là, j'ai fait attention à tout, remplacé par ton code et bien enregistré mon xlam.

Merci encore