Copie du screenshot dans body

**LWKTECH** · 02/02/2012, 10h03

Bonjour,
Je cherche à coller un screenshot fait avec la commande CopyPicture dans le Body d'un email.
Merci de votre aide !

Pour être plus clair voici mon code :

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
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)

'---Message box---'
Dim answer As String
answer = MsgBox("Voulez-vous enregistrer le fichier", vbYesNo, "Enregistrement")
If answer = vbNo Then Cancel = True
If answer = vbYes Then

'---Open Outlook type stuff---'
Set OutlookApp = CreateObject("Outlook.Application")
Set OlObjects = OutlookApp.GetNamespace("MAPI")
Set Mail = OutlookApp.CreateItem(olMailItem)

'---Add recipients---'
Mail.Recipients.Add ("email@email.com")

'---Add subject---'
Mail.Subject = "Sujet du mail"

'---Add body---'
ActiveSheet.Range("A1:Q38").CopyPicture >>> Copie le tableau dans le presse-papier
Mail.Body = >>> INSERER LE SCREENSHOT ICI<<<
Mail.Display
Mail.Send

'---Give conformation of sent message---'
MsgBox "Le fichier a bien été enregistré", , "Fichier enregistré"

End If

'---Save the document---'
'---Me.Worksheets.Save---'

End Sub

**Theze** · 02/02/2012, 13h16

Bonjour,

Pour une image issu du presse-papier je n'ai pas encore trouvé mais pour du texte tu peux tester ce qui suit.
Il faut cocher la référence "Microsoft Forms 2.0 Object Library". Si tu ne la trouve pas, ajoute une Form dans ton classeur puis vire la, la référence sera ajoutée d'office.

Code :

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

1
2
3
4
5
6
7
 
ActiveSheet.Range("A1:Q38").Copy 'Picture
 
With New dataObject
    .GetFromClipboard
    Mail.Body = .GetText(1)
End With

Hervé.

**LWKTECH** · 02/02/2012, 13h57

Le script ne me met pas d'erreur, mais aucun mail ne part maintenant

**Jean-Philippe André** · 02/02/2012, 14h03

Hello,

il ne part pas mais s'affiche-t-il au moins ?

**LWKTECH** · 02/02/2012, 15h29

Arf désolé j'ai fait une petite boulette

Mais c'est bon j'ai vu pourquoi ça ne marchait pas.

Maintenant j'ai une autre question. Voilà est-il possible d'avoir les lignes et colonnes alignées. Je veux dire par la avoir le tableau comme si il était en HTML.

Désolé si je suis un peu chi*nt

**Jean-Philippe André** · 02/02/2012, 15h43

Hum,

ca serait pas plus simple de passer par la fonction qui envoie une plage de données directement ?

http://outlook.developpez.com/faq/?p...VBA_Send_Range

**LWKTECH** · 03/02/2012, 10h14

Oui ta suggestion est très bien. Sauf que je n'arrive pas a fusionner mon code avec celui que tu me proposes (c'est a dire conservé l'envoi du mail lors de l'enregistrement, et compléter les champs "sujet" et "destinataire" automatiquement). HELP please

EDIT : J'ai réussi a exécuter l'envoie auto avec destinataire auto. ~~Il me reste a définir automatiquement les "cases" à sélectionner~~ >> FAIT.

EDIT 2 : Je n'arrive pas a éxecuter le code lors de l'enregistrement du fichier. HELP please

**Jean-Philippe André** · 03/02/2012, 10h51

Tu as fait le plus dur, pour la selection automatique, il suffit de changer la fonction SendRangeByMail comme ceci :

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
Sub SendRangeByMail(rngeSend As Range)
 
 
   With Application
 
      On Error Resume Next
 
 
      ' rngeSend Is Nothing lorsque l'utilisateur ne fait
      ' aucun choix
 
       If rngeSend Is Nothing Then Exit Sub
 
      On Error GoTo 0
 
      ' Exporte la plage vers un fichier de type HTML;
      ' ceci afin de respecter la mise en page de la
      ' plage
 
      .ActiveWorkbook.PublishObjects.Add(4, "C:\Temp\XLRange.htm", rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
 
      ' Appelle la routine qui va se charger de créer
      ' un mail
 
      Call PrepareOutlookMail("C:\Temp\XLRange.htm")
 
      ' Le fichier HTML n'est plus nécessaire
 
      Kill "C:\Temp\XLRange.htm"
 
   End With ' With Application
 
End Sub

**LWKTECH** · 03/02/2012, 11h12

Merci jpcheck. Je pense que l'on a trouvé la solution en même temps

Maintenant je cherche à mettre la touche finale c'est a dire intégrer ma commande d’exécution du code lorsque l'on enregistre le document. Mais je bloque là...

**Jean-Philippe André** · 03/02/2012, 11h26

Tu peux expliciter un peu ce que tu cherches à faire, j'ai du mal à saisir

**LWKTECH** · 03/02/2012, 11h32

Pas de problème.

Si tu regardes mon code que j'ai donné sur mon premier post, la commande "envoi mail" est exécuter lorsque l'utilisateur enregistre (sauvegarde) le fichier après une modification par exemple.

Lorsque l'utilisateur enregistre le fichier une fenêtre de confirmation apparaît, et s'il clic sur "oui" le document est sauvegardé et le mail est ensuite envoyé.

Tu vois le truc ?

**Jean-Philippe André** · 03/02/2012, 11h45

Certes, mais c'est quoi la question à laquelle on doit répondre ?

**LWKTECH** · 03/02/2012, 12h32

Ah oui pardon

C'est comment intégré mon code qui permet de lancer le reste du code lorsque que l'on sauvegarde le fichier (piouf, ca c'est de la phrase !

).

Voici ce que j'ai actuellement au niveau de mon code :

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
 
Option Explicit
Public Function ReadFile(sFileName) As String
Dim fso As Object, fFile As Object
Dim sTemp As String
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fFile = fso.OpenTextFile(sFileName, 1, False)
   sTemp = fFile.ReadAll
   fFile.Close
   Set fFile = Nothing
   ReadFile = sTemp
End Function
'---Open Outlook type stuff---'
Sub PrepareOutlookMail(ByVal sFileName As String)
Dim appOutlook As Outlook.Application
Dim Mail As Outlook.MailItem
   Set appOutlook = CreateObject("Outlook.Application")
   If Not (appOutlook Is Nothing) Then
      Set Mail = appOutlook.CreateItem(olMailItem)
      Mail.HTMLBody = ReadFile(sFileName)
      Mail.Display
'---Recipients---'
      Mail.Recipients.Add ("email@email.com")
'---Subject---'
      Mail.Subject = "Mise à jour stock consommables"
      Mail.Display
      Mail.Send
      Set Mail = Nothing
      Set appOutlook = Nothing
   End If
End Sub
'---Body Mail---'
Sub SendRangeByMail()
Dim rngeSend As Range
   With Application
      On Error Resume Next
      Set rngeSend = Range("A1", "P45")
       If rngeSend Is Nothing Then Exit Sub
      On Error GoTo 0
      .ActiveWorkbook.PublishObjects.Add(4, "E:\XLRange.htm", rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
      Call PrepareOutlookMail("E:\XLRange.htm")
      Kill "E:\XLRange.htm"
   End With
End Sub

**Jean-Philippe André** · 03/02/2012, 12h42

il faut simplement intercaler le code à la place de

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
 
'...
'---Open Outlook type stuff---'
Set OutlookApp = CreateObject("Outlook.Application")
Set OlObjects = OutlookApp.GetNamespace("MAPI")
Set Mail = OutlookApp.CreateItem(olMailItem)
 
'---Add recipients---'
Mail.Recipients.Add ("email@email.com")
 
'---Add subject---'
Mail.Subject = "Sujet du mail"
 
'---Add body---'
ActiveSheet.Range("A1:Q38").CopyPicture >>> Copie le tableau dans le presse-papier
Mail.Body = >>> INSERER LE SCREENSHOT ICI<<<
Mail.Display
Mail.Send

avec

Code :

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

SendRangeByMail

**LWKTECH** · 03/02/2012, 12h52

Euh

Pas tout compris ce qu'il copier coller et ou.

**Jean-Philippe André** · 03/02/2012, 13h31

Bon ben je fais pour toi, histoire qu'on achève la bête à terre

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
63
Option Explicit
Public Function ReadFile(sFileName) As String
Dim fso As Object, fFile As Object
Dim sTemp As String
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fFile = fso.OpenTextFile(sFileName, 1, False)
   sTemp = fFile.ReadAll
   fFile.Close
   Set fFile = Nothing
   ReadFile = sTemp
End Function
'---Open Outlook type stuff---'
Sub PrepareOutlookMail(ByVal sFileName As String)
Dim appOutlook As Outlook.Application
Dim Mail As Outlook.MailItem
   Set appOutlook = CreateObject("Outlook.Application")
   If Not (appOutlook Is Nothing) Then
      Set Mail = appOutlook.CreateItem(olMailItem)
      Mail.HTMLBody = ReadFile(sFileName)
      Mail.Display
'---Recipients---'
      Mail.Recipients.Add ("email@email.com")
'---Subject---'
      Mail.Subject = "Mise à jour stock consommables"
      Mail.Display
      Mail.Send
      Set Mail = Nothing
      Set appOutlook = Nothing
   End If
End Sub
'---Body Mail---'
Sub SendRangeByMail()
Dim rngeSend As Range
   With Application
      On Error Resume Next
      Set rngeSend = Range("A1:P45")
       If rngeSend Is Nothing Then Exit Sub
      On Error GoTo 0
      .ActiveWorkbook.PublishObjects.Add(4, "E:\XLRange.htm", rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
      Call PrepareOutlookMail("E:\XLRange.htm")
      Kill "E:\XLRange.htm"
   End With
End Sub
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
 
'---Message box---'
Dim answer As String
answer = MsgBox("Voulez-vous enregistrer le fichier", vbYesNo, "Enregistrement")
If answer = vbNo Then Cancel = True
If answer = vbYes Then
 
SendRangeByMail
'---Give conformation of sent message---'
MsgBox "Le fichier a bien été enregistré", , "Fichier enregistré"
 
End If
 
'---Save the document---'
'---Me.Worksheets.Save---'
 
End Sub

**LWKTECH** · 03/02/2012, 14h35

Ah oui c'était tout bête !
Merci beaucoup jpcheck !

**Jean-Philippe André** · 03/02/2012, 14h41

Si la solution apportée te convient, merci de l'indiquer en cliquant sur le bouton résolu

Copie du screenshot dans body

Macros et VBA Excel

Discussions similaires

Partager

Partager