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 64 65 66 67 68
| Sub SendMails()
Dim MonOutlook As New Outlook.Application
Dim MyMail As MailItem
Dim AdresseFile As String, Civilité As String, objet As String
Dim CorpsTexte(), FichiersAttachés()
Dim NbFichiers As Integer, NbTextes As Integer, PosDeb As Integer, PosFin As Integer, NbMsgEnvoyés As Integer, NbMsgErr As Integer
Dim Dummy As Integer, TxtMsgBox As String, NoLigne As Double, TexteMessage As String, adresse_mail As String
Dim Feuille As Worksheet
Dim MailError As Boolean
Set MyMail = MonOutlook.CreateItem(olMailItem)
(...)
'--------------------------------------------------------------------------
' Envoi du message
'--------------------------------------------------------------------------
Do While Cells(NoLigne, 4).Value <> vbEmpty
(...)
'--------------------------------------------------------------------------
' Création du mail
'--------------------------------------------------------------------------
Set MyMail = MonOutlook.CreateItem(olMailItem)
MyMail.To = adresse_mail
MyMail.Subject = objet
MyMail.Body = TexteMessage
If NbFichiers > 0 Then
For Dummy = 1 To NbFichiers
MyMail.Attachments.Add (FichiersAttachés(Dummy))
Next Dummy
End If
On Error Resume Next
MyMail.Send
If Err.Number <> 0 Then
Cells(NoLigne, 8) = "Problème: message non envoyé. " & Err.Number & " " & Err.Description
NbMsgErr = NbMsgErr + 1
Else
Cells(NoLigne, 8) = "Envoyé"
NbMsgEnvoyés = NbMsgEnvoyés + 1
End If
End If
End If
NoLigne = NoLigne + 1
Loop
'--------------------------------------------------------------------------------------------------------------------------------------------------------
Set MonOutlook = Nothing
If NoSend = True Then
MsgBox ("Aucun message n'a été réellement envoyé! ")
Else
TxtMsgBox = Format(NbMsgEnvoyés, "0") & IIf(NbMsgEnvoyés > 1, " messages envoyés.", " message envoyé.") & Chr(10)
If NbMsgErr = 0 Then TxtMsgBox = TxtMsgBox & "Aucun message n'a généré d'erreur d'envoi"
If NbMsgErr = 1 Then TxtMsgBox = TxtMsgBox & "Un message a généré une erreur d'envoi (cf base d'adresses)"
If NbMsgErr > 1 Then TxtMsgBox = TxtMsgBox & Format(NbMsgErr, "0") & " messages ont généré des erreurs d'envoi (cf base d'adresses)"
If NbMsgErr = 0 And NbMsgEnvoyés = 0 Then TxtMsgBox = "Sélectionnez les message à envoyer en indiquant un 'x' en face de l'adresse email"
MsgBox (TxtMsgBox)
End If
End Sub |
Partager