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 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
| Public Sub EnvoiMassif()
'Ajouter les références suivantes :
'Microsoft Outlook
'Microsoft DAO
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Dim oDB As DAO.Database
Dim strContenu As String
Dim oRst0 As DAO.Recordset
Dim oRst1 As DAO.Recordset
Dim strTo As String
Dim sqlMail As String
'evalue si outlook est ouvert
If IsOfficeRunning(App_outlook, True) Then
'Instancie Outlook
Set oDB = CurrentDb
Set oApp = CreateObject("Outlook.Application")
'Crée un nouveau message
'sqlMail = "SELECT * FROM tblMessage;"
'Set oRst0 = oDB.OpenRecordset(sqlMail)
'oRst0.MoveLast
Set oMail = oApp.CreateItem(olMailItem)
oMail.Body = "Tapez votre message ici" 'oMail.Body = oRst0.Fields("txtcorps")
oMail.Subject = "MAILLING : Tapez le sujet du message" 'oRst0.Fields("strObjet") & " du " & oRst0.Fields("dtCrea")
'Ouvre un recordset sur les clients
If strFiltreallpub = Empty Then
Set oRst1 = oDB.OpenRecordset("SELECT mail1 FROM Tb_contacts")
Else
Set oRst1 = oDB.OpenRecordset("SELECT mail1 FROM Tb_contacts WHERE" & strFiltreallpub)
End If
'Boucle sur chaque client et les ajoute au champ BCC du mail
While Not oRst1.EOF
strTo = strTo & oRst1.Fields("mail1") & "; "
oRst1.MoveNext
Wend
'Supprime la dernière virgule
oMail.BCC = Left(strTo, Len(strTo) - 2)
oMail.To = "Mailling-list@maboite.fr"
'Envoi du mail
oMail.Save
'oMail.Display
'oRst0.Close
oRst1.Close
Set oRst0 = Nothing
Set oRst1 = Nothing
Set oDB = Nothing
'Ferme Outlook
'oApp.Quit
Set oApp = Nothing
MsgBox "Le mail à été placé dans le dossier brouillons de votre outlook", vbInformation
Else
Dim stAppName As String
stAppName = "C:\Program Files\Microsoft Office\OFFICE11\OUTLOOK.EXE"
Call Shell(stAppName, 1)
Dim i As Long
DoEvents
'cette boucle sert à créer une attente entre les deux affectations
For i = 1 To 1000000000
Next
'Instancie Outlook
Set oDB = CurrentDb
Set oApp = CreateObject("Outlook.Application")
'Crée un nouveau message
'sqlMail = "SELECT * FROM tblMessage;"
'Set oRst0 = oDB.OpenRecordset(sqlMail)
'oRst0.MoveLast
Set oMail = oApp.CreateItem(olMailItem)
oMail.Body = "Tapez votre message ici" 'oMail.Body = oRst0.Fields("txtcorps")
oMail.Subject = "MAILLING : Tapez le sujet du message" 'oRst0.Fields("strObjet") & " du " & oRst0.Fields("dtCrea")
'Ouvre un recordset sur les clients
If strFiltreallpub = Empty Then
Set oRst1 = oDB.OpenRecordset("SELECT mail1 FROM Tb_contacts")
Else
Set oRst1 = oDB.OpenRecordset("SELECT mail1 FROM Tb_contacts WHERE" & strFiltreallpub)
End If
'Boucle sur chaque client et les ajoute au champ BCC du mail
While Not oRst1.EOF
strTo = strTo & oRst1.Fields("mail1") & "; "
oRst1.MoveNext
Wend
'Supprime la dernière virgule
oMail.BCC = Left(strTo, Len(strTo) - 2)
oMail.To = "Mailling-list@maboite.fr"
'Envoi du mail
oMail.Save
'oMail.Display
'oRst0.Close
oRst1.Close
Set oRst0 = Nothing
Set oRst1 = Nothing
Set oDB = Nothing
'Ferme Outlook
'oApp.Quit
Set oApp = Nothing
MsgBox "Le mail à été placé dans le dossier brouillons de votre outlook", vbInformation
End If
End Sub |
Partager