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