Création d'une image jpg via une Macro.

**djflnj** · 17/09/2010, 21h25

Bonsoir à toutes et tous,

Je voudrais savoir si quelqu'un peut m'aider sur mon code si suivant.
explication:

J'ai une macro " Sub Macro4_save_maison() " qui fonctionne très bien mais je voudrais lui rajouter une fonction supplémentaire, que j'ai trouvé sur le forum, une macro qui permet de faire une image jpg ou gif ( de préférence je hopte pour le JPG ) et je voudrais rajouter cette macro à ma macro.

Quand je clique sur mon Bouton "Enregistrement" à lequel j'ai affecté ma macro je voudrais qu'il créer un fichier image.jpg qui porterait le même nom que ma facture ex : "17092010_FACTURE N°_2010-xx.xls"

Que l'enregistrement fichier image.jpg ce face dans le même dossier qui vient d'être crèèr par la partie1 de ma macro.

Mais quand la macro arrive à la partie 2, celle que j'ai rajouté à ma macro rien ne ce passe je vous joint ci-dessous ma macro complète.

Avec tout mes remerciement par avance
'PARTIE 1

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
Sub Macro4_save_maison()
Dim Chemin1$, Chemin2$, Chemin3$, Chemin4$, Types$, Client$, Fichier$, Numfact$, Jour$, Facturation$, Client1$
Chemin1 = "i:\Factures\"
Chemin2 = "d:\Users\admin\Desktop\MENU_Factures\"
Chemin3 = "d:\Users\admin\Desktop\MENU_Factures\"
Chemin4 = "i:\Factures\1 - MENU_Factures\"
Jour = Format(Day(Now()), "00") & Format(Month(Now()), "00") & Year(Now)
Client = Range("c4")
Client1 = Range("a1")
Numfact = Range("c3")
Types = Range("b3")
Facturation = Range("a1")
Fichier = Jour & "_" & Types & "_" & Numfact & ".xls"
 
' Enregistrement sur clé USB dossier client
 
If Dir(Chemin1 & Client, 16) = "" Then MkDir Chemin1 & Client
ActiveWorkbook.SaveAs Chemin1 & Client & "\" & Fichier
 
' Sauvegarde sur ordi maison Fichier xlsm
 
Facturation = Facturation & ".xlsm"
If Dir(Chemin2 & Client1, 16) = "" Then MkDir Chemin2 & Client1
ActiveWorkbook.SaveAs Chemin2 & Client1 & "\" & Client1
 
' Enregistrement sur ordi maison dossier client
 
If Dir(Chemin3 & Client, 16) = "" Then MkDir Chemin3 & Client
ActiveWorkbook.SaveAs Chemin3 & Client & "\" & Fichier
 
' Sauvegarde sur clé USB Fichier xlsm
 
Facturation = Facturation & ".xlsm"
If Dir(Chemin4 & Client1, 16) = "" Then MkDir Chemin4 & Client1
ActiveWorkbook.SaveAs Chemin4 & Client1 & "\" & Client1
 
'End Sub

'PARTIE 2

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
'Sub ExtractionImagesFeuille()
'auteur:SilkyRoad
 
Dim Pict As Picture
Dim Nb As Byte
 
Application.ScreenUpdating = False
 
For Each Pict In Worksheets("Facture").Pictures
Pict.CopyPicture 'copie l'image
 
With Worksheets("Facture").ChartObjects.Add(0, 0, Pict.Width, Pict.Height).Chart
.Paste 'colle l'image dans un graphique temporaire
'Sauvegarde au format image, dans le même répertoire que ce classeur.
.Export ThisWorkbook.Path & "\" & Pict.Name & ".gif", "GIF"
End With
 
'Supprime le graphique
Nb = Worksheets("Facture").ChartObjects.Count
Worksheets("Facture").ChartObjects(Nb).Delete
Next Pict
 
Application.ScreenUpdating = True
End Sub

**patricktoulon** · 18/09/2010, 21h42

bonjour et bien venu sur le forum

tout d'abords il faudrai savoir si l'image que tu veux exporter tu l'a inséré ou si c'est une image des cellules

dans le cas numéro 2 il faudrai t que tu rajoute en début de 2eme macro

Code :

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

1
2
 
sheets("blablabla").range("a1:g30).copypicture 'et après l'insérer dans le chart vide

au plaisir

**djflnj** · 19/09/2010, 21h33

bonsoir,

merci pour ta réponse .

oui c'est pour inserer une image de célulle.

mais à quel endroit doit-je inserer cette ligne

peut tu, me remetre le code macro complet stp

merci

**mercatog** · 20/09/2010, 00h07

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
Sub NumeriseFactureJpg()
Dim Plage As Range
 
Application.ScreenUpdating = False
With Sheets("Facture")
    Set Plage = .Range("A1:M40")
    Plage.CopyPicture
    With .ChartObjects.Add(Plage.Left, Plage.Top, Plage.Width, Plage.Height).Chart
        .Paste
        .Export ThisWorkbook.Path & "\Essai.jpg", "JPG"
    End With
    .ChartObjects(.ChartObjects.Count).Delete
End With
MsgBox "Numérisation facture terminée"
Set Plage = Nothing
End Sub

**djflnj** · 20/09/2010, 09h20

Bonjour,

l'image ce créer bien merci pour cette aide mais je voudrais quelle s'enregistre dans le dossier Client et non dans le dossier dans lequel j'execute le fichier xlsm

cordialement

**mercatog** · 20/09/2010, 11h34

adaptes cette ligne donc à tes besoins

Code :

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

        .Export ThisWorkbook.Path & "\Essai.jpg", "JPG"

en remplaçant le chemin et le nom de l'image

**djflnj** · 20/09/2010, 14h41

re-bonjour

Désolé, mais depuis se matin j'essai d'adapter cette ligne mais celle ou elle ne fonctionne pas ou le fichier ne s'enregistre pas là ou je le voudrais.
merci de pouvoir de nouveau m'aider.

Se que je souhaiterais c'est que mon fichier .jpg porte le même nom que mon fichier .xls et que celui-ci s'enregistre dans le même dossier que le fichier .xls
le fichier qui se crée dans le dossier Parent et sous cette forme
''1 - Menu de Facturation Radio PlurielFRAM20092010_DEVIS N°_2010-46.jpg''
et je souhaiterais qu'il soit sous cette forme là :
'' FRAM20092010_DEVIS N°_2010-46.jpg''

j'ai essayé plein de modification dans cette ligne ''.Export ThisWorkbook.Path ''
tel qu'en rajoutant le chemin ou je voulais qu'il s'enregistre enlever le ''.Path'' et le remplacer par '' Save, SaveAs, Saved, ... '' mais je tombe sur une erreur.

je ne sais plus quoi essayer, j'espère que tes lumière pourront m'aider.

Voici toute la macro :

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
59
60
61
62
Sub Macro2_save()
'PARTIE 1
 
Dim Chemin1$, Chemin2$, Chemin3$, Chemin4$, Types$, Client$, Fichier$, Numfact$, Jour$, Facturation$, Client1$, Image$
 
' Création et Enregistrement du client sur la clé USB
Chemin1 = "i:\MENU_Factures\"
 
' Ecrasement de" 1 - Menu de Facturation Radio Pluriel.xlsm" sur l'ordi bureau
Chemin2 = "F:\Users\Christ\Desktop\MENU_Factures\"
 
' Création et Enregistrement du client sur ordi maison.
Chemin3 = "F:\Users\Christ\Desktop\MENU_Factures\"
 
'Ecrasement de" 1 - Menu de Facturation Radio Pluriel.xlsm" sur la clé USB
Chemin4 = "i:\MENU_Factures\"
 
Jour = Format(Day(Now()), "00") & Format(Month(Now()), "00") & Year(Now)
Client = Range("c4")
Client1 = Range("a1")
Numfact = Range("c3")
Types = Range("b3")
Facturation = Range("a1")
Fichier = Jour & "_" & Types & "_" & Numfact & ".xls"
Image = Jour & "_" & Types & "_" & Numfact & ".jpg"
 
' Création et Enregistrement du client sur la clé USB
If Dir(Chemin1 & Client, 16) = "" Then MkDir Chemin1 & Client
ActiveWorkbook.SaveAs Chemin1 & Client & "\" & Fichier
 
' Ecrasement de" 1 - Menu de Facturation Radio Pluriel.xlsm" sur l'ordi bureau
Facturation = Facturation & ".xlsm"
If Dir(Chemin2 & Client1, 16) = "" Then MkDir Chemin2 & Client1
ActiveWorkbook.SaveAs Chemin2 & Client1 & "\" & Client1
 
' Enregistrement sur ordi maison dossier client
If Dir(Chemin3 & Client, 16) = "" Then MkDir Chemin3 & Client
ActiveWorkbook.SaveAs Chemin3 & Client & "\" & Fichier
 
' Ecrasement de" 1 - Menu de Facturation Radio Pluriel.xlsm" sur la clé USB
Facturation = Facturation & ".xlsm"
If Dir(Chemin4 & Client1, 16) = "" Then MkDir Chemin4 & Client1
ActiveWorkbook.SaveAs Chemin4 & Client1 & "\" & Client1
 
'PARTIE 2
 
Dim Plage As Range
 
Application.ScreenUpdating = False
With Sheets("Facture")
    Set Plage = .Range("b1:g51")
    Plage.CopyPicture
    With .ChartObjects.Add(Plage.Left, Plage.Top, Plage.Width, Plage.Height).Chart
        .Paste
        .Export ThisWorkbook.Path & Client & Image
    End With
    .ChartObjects(.ChartObjects.Count).Delete
End With
MsgBox "Numérisation  de la facture terminée"
Set Plage = Nothing
 
End Sub

**mercatog** · 20/09/2010, 15h07

Je ne comprends pas la question des Chemin1 à chemin4 (qui sont en double)
sinon, pour enregistrer dans chemin2 par exemple, (j'ai revu le code au passage)

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
Sub Macro2_save()
Dim Plage As Range
Dim Types$, Client$, Fichier$, Numfact$, Jour$, Facturation$, Client1$, Image$
Const Chemin1 = "i:\MENU_Factures\"
Const Chemin2 = "F:\Users\Christ\Desktop\MENU_Factures\"
Const Chemin3 = "F:\Users\Christ\Desktop\MENU_Factures\"
Const Chemin4 = "i:\MENU_Factures\"
 
Application.ScreenUpdating = False
With Sheets("Facture")
    Jour = Format(Now, "ddmmyyyy")
    Client = .Range("C4")
    Client1 = .Range("A1")
    Numfact = .Range("C3")
    Types = .Range("B3")
    Facturation = .Range("A1")
    Facturation = Facturation & ".xlsm"
 
    Fichier = Jour & "_" & Types & "_" & Numfact & ".xls"
    Image = Jour & "_" & Types & "_" & Numfact & ".jpg"
 
    ' Création et Enregistrement du client sur la clé USB
    If Dir(Chemin1 & Client, 16) = "" Then MkDir Chemin1 & Client
    ThisWorkbook.SaveAs Chemin1 & Client & "\" & Fichier
 
    ' Ecrasement de" 1 - Menu de Facturation Radio Pluriel.xlsm" sur l'ordi bureau
    If Dir(Chemin2 & Client1, 16) = "" Then MkDir Chemin2 & Client1
    ThisWorkbook.SaveAs Chemin2 & Client1 & "\" & Client1
 
    ' Enregistrement sur ordi maison dossier client
    If Dir(Chemin3 & Client, 16) = "" Then MkDir Chemin3 & Client
    ThisWorkbook.SaveAs Chemin3 & Client & "\" & Fichier
 
    ' Ecrasement de" 1 - Menu de Facturation Radio Pluriel.xlsm" sur la clé USB
    If Dir(Chemin4 & Client1, 16) = "" Then MkDir Chemin4 & Client1
    ThisWorkbook.SaveAs Chemin4 & Client1 & "\" & Client1
 
    Set Plage = .Range("B1:G51")
    Plage.CopyPicture
    With .ChartObjects.Add(0, 0, Plage.Width + 5, Plage.Height + 5).Chart
        .Paste
        .Export Chemin2 & Client & "\" & Image
    End With
    .ChartObjects(.ChartObjects.Count).Delete
End With
MsgBox "Numérisation de la facture terminée"
Set Plage = Nothing
End Sub

**patricktoulon** · 20/09/2010, 15h21

bonjour

a première vu j'ai survoler ton code

déjà ci tu pouvais le rééditer entre les balises ça serai plus facile pour les lecteurs

et donc a la fin en partie 2 tu sauvegarde l'image venant du sheets facture

peut être faudrais til le réactiver ce classeur étant donner que tu le sauve plusieurs fois avec un nom diffèrent donc quand tu arrive a la partie 2 tu n'est plus sur le classeur de base forcement ta macro va buger

lenomduclasseur.activate juste avant la partie2

au plaisir

**djflnj** · 21/09/2010, 23h20

Envoyé par mercatog

Je ne comprends pas la question des Chemin1 à chemin4 (qui sont en double)
sinon, pour enregistrer dans chemin2 par exemple, (j'ai revu le code au passage)

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
Sub Macro2_save()
Dim Plage As Range
Dim Types$, Client$, Fichier$, Numfact$, Jour$, Facturation$, Client1$, Image$
Const Chemin1 = "i:\MENU_Factures\"
Const Chemin2 = "F:\Users\Christ\Desktop\MENU_Factures\"
Const Chemin3 = "F:\Users\Christ\Desktop\MENU_Factures\"
Const Chemin4 = "i:\MENU_Factures\"
 
Application.ScreenUpdating = False
With Sheets("Facture")
    Jour = Format(Now, "ddmmyyyy")
    Client = .Range("C4")
    Client1 = .Range("A1")
    Numfact = .Range("C3")
    Types = .Range("B3")
    Facturation = .Range("A1")
    Facturation = Facturation & ".xlsm"
 
    Fichier = Jour & "_" & Types & "_" & Numfact & ".xls"
    Image = Jour & "_" & Types & "_" & Numfact & ".jpg"
 
    ' Création et Enregistrement du client sur la clé USB
    If Dir(Chemin1 & Client, 16) = "" Then MkDir Chemin1 & Client
    ThisWorkbook.SaveAs Chemin1 & Client & "\" & Fichier
 
    ' Ecrasement de" 1 - Menu de Facturation Radio Pluriel.xlsm" sur l'ordi bureau
    If Dir(Chemin2 & Client1, 16) = "" Then MkDir Chemin2 & Client1
    ThisWorkbook.SaveAs Chemin2 & Client1 & "\" & Client1
 
    ' Enregistrement sur ordi maison dossier client
    If Dir(Chemin3 & Client, 16) = "" Then MkDir Chemin3 & Client
    ThisWorkbook.SaveAs Chemin3 & Client & "\" & Fichier
 
    ' Ecrasement de" 1 - Menu de Facturation Radio Pluriel.xlsm" sur la clé USB
    If Dir(Chemin4 & Client1, 16) = "" Then MkDir Chemin4 & Client1
    ThisWorkbook.SaveAs Chemin4 & Client1 & "\" & Client1
 
    Set Plage = .Range("B1:G51")
    Plage.CopyPicture
    With .ChartObjects.Add(0, 0, Plage.Width + 5, Plage.Height + 5).Chart
        .Paste
        .Export Chemin2 & Client & Image
    End With
    .ChartObjects(.ChartObjects.Count).Delete
End With
MsgBox "Numérisation de la facture terminée"
Set Plage = Nothing
End Sub

bonsoir,

merci pour tes corrections, elles sont beaucoup plus simple.

le fichier ce créer bien comme il le faut , mais il faudrait qu'il s'enregistre dans le dossier du client et pas dans le dossier ou se trouve tout les dossier client, c'est a dire que quant il créer le fichier .jpg il faudrait qu'il s'enregistre dans le chemin du dossier clien qui vient de se créer.
peut tu me trouver une solution

merci beaucoup pour se super travail

**mercatog** · 21/09/2010, 23h43

Et quel est ce dossier client?

Edit
j'ai édité le code, un "\" entre le dossier et le fichier image.

je redit encore, à toi de remplacer dans la ligne ci-dessous Chemin2 & Client & "\" par le dossier que tu veux

Code :

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

.Export Chemin2 & Client & "\" & Image

**djflnj** · 22/09/2010, 15h40

Bonjour,

Voila , tout est bon maintenant tout s'enregistre bien dans les bons dossiers aussi bien le fichier xlsm, le xls et le jpg merci à toutes les personnes qui n'ont donné de leurs temps et de leurs patiences.

Mais il y a de nouveau une option que je voudrais rajouter à mon projet,
celle de rajouter en même temp que l'enregistrement des autres fichiers xlsm, xls et jpg, que mon fichier s'enregistre de la même manière que les autres, mais en PDF et que se PDF soit mis automatiquement dans Outlook en pièce jointe, de même que l'adresse mail soit mis également automatiquement dans la zone d'envoi du mail dans Outlook.

Cordialement.

**mercatog** · 22/09/2010, 15h47

Clos se sujet avec Résolu. et ouvre un autre avec les nouvelles questions. comme ça, ça sera profitable pour tout le monde.

Création d'une image jpg via une Macro. [XL-2007]

Macros et VBA Excel

Discussions similaires

Partager

Partager