Problème pour garder la mise en forme d'un document à envoyer par mail depuis excel
bonjour à tous,
A l'aide de la FaQ Developpez et l'aide de Microsoft j'ai réussi à coder une macro excel qui me permet d'envoyer un mail à des listes d'utilisateurs.
La génération du mail et son envoi marche très bien mais le corps du mail n'est pas ce que je souhaite.
Pour le corps du mail je dois sélectionner un document word et copier son contenu.
Mais ce que j’envoie par mail est du text brut. J'ai perdu la mise en page, les tableaux les couleurs etc...
Il y a surement quelque chose que je rate mais je ne trouve pas quoi. Les exemples que je trouve envoient le word en pj mais ce n'est pas ce que je souhaite faire.
Des pistes pour que je me corrige ?
Merci
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
| Sub SendOutlookMessages()
Dim OL As Object, MailSendItem As Object
Dim W As Object
Dim MsgTxt As String, SendFile As String
Dim MsgTotal As Variant
'******************************
'***********WORD***************
'******************************
'Selection du document word à envoyer
SendFile = Application.GetOpenFilename(Title:="Select MS Word " & _
"file to mail, then click 'Open'", buttontext:="Send", _
MultiSelect:=False)
'Ouverture du document word
Set W = GetObject(SendFile)
'Recupération du contenu du document
MsgTotal = W.Range(Start:=W.Paragraphs(1).Range.Start, _
End:=W.Paragraphs(W.Paragraphs.Count).Range.End)
'Arret de la session word
Set W = Nothing
'******************************
'***********FIN WORD***********
'******************************
'******************************
'***********OUTLOOK************
'******************************
'Creation d'un mail Outlook
Set OL = CreateObject("Outlook.Application")
Set MailSendItem = OL.CreateItem(olMailItem)
'Récupération de mes listes de mails dans le classeur excel
Dim ArrayListeDesMails As Variant
Sheets("Liste Appli").Activate
ArrayListeDesMails = ActiveSheet.ListObjects("TableauListeDesMails").DataBodyRange
'Pour chaque liste de mails
For Each liste In ArrayListeDesMails
'Creation du message et envoi
With MailSendItem
.Subject = SendFile
.HTMLBody = MsgTotal
'.Body = MsgTotal
.To = liste
.Sender = "moi@moi.fr"
.Send
End With
Next
Set OL = Nothing
'******************************
'***********FIN OUTLOOK********
'******************************
End Sub |
