Copie du screenshot dans body [Résolu]

[Loweack]

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 :

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]

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 :

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

Hervé.

[Loweack]

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

[jpcheck]

Hello,

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

[Loweack]

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

[jpcheck]

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

[Loweack]

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

[jpcheck]

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

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
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

[Loweack]

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à...

[jpcheck]

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

[Loweack]

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 ?

[jpcheck]

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

[Loweack]

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 :

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

[jpcheck]

il faut simplement intercaler le code à la place de

Code :

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 :

SendRangeByMail

[Loweack]

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

[jpcheck]

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

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
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

[Loweack]

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

[jpcheck]

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