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
| Sub EnvoiMessage()
'JJM - Envoi un message à Outlook, sans l'ouvrir
'Ajouter la Référence : "Microsoft Outlook XX.X Object Library"
Dim vDestinataires, vCC, vObjet, vMessage, vPJ, vLigne, rc
Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Bonus As String
Dim Msg As String
'Stop
Application.ScreenUpdating = False
On Error Resume Next
Worksheets("Demo").Activate
'Récup. destinataires
For Each vLigne In [B7:B16]
If vLigne <> "" Then vDestinataires = vDestinataires & vLigne & ";"
Next
'Récup. CC
For Each vLigne In [C7:C16]
If vLigne <> "" Then vCC = vCC & vLigne & ";"
Next
'Récup Objet
vObjet = Range("B18").Value
'Récup. message, avec sauts de ligne
For Each vLigne In [B20:B24]
vMessage = vMessage & vLigne & vbLf
Next
'Récup. PJ
vPJ = Range("B26").Value
'Crée l'objet Outlook
Set OutlookApp = New Outlook.Application
'Création message Outlook et transmission
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = vDestinataires 'Liste des destinataires
.CC = vCC 'Liste des destinataires CC
.BCC = Range("Demo!D7") 'liste des destinataires CCC
.Importance = olImportanceHigh 'Importance du message
.Subject = vObjet 'Objet
.Body = vMessage 'Texte du message
.Attachments = vPJ 'Pièce jointe
.ReadReceiptRequested = True 'Demande de confirmation de lecture
.Display
End With
End Sub |
Partager