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
| Public Sub RéponsesCandidatures()
'Ajouter les références suivantes :
'Microsoft Outlook
'Microsoft DAO
Private Const CST_EmailFrom As String = "recrutement@domaine.fr"
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Dim oDB As DAO.Database
Dim olApp As Outlook.Application, olAcc As Outlook.Account
Dim strContenu As String
Dim oRst1 As DAO.Recordset
Dim strTo As String
Dim srtFrom As String
Dim sqlMail As String
'Instancie Outlook
Set oDB = CurrentDb
For Each olAcc In olApp.Session.Accounts
If olAcc.CurrentUser.Address = CST_EmailFrom Then Exit For
Next olAccSet oApp = CreateObject("Outlook.Application")
'Ouvre un recordset sur les clients
Set oRst1 = oDB.OpenRecordset("SELECT [Candidat] & '@' & [Domaine] AS Mail, DonneesCandidatures.Demande, TblRepCandidat.strObjet, IIf(Right([txtCorps1],5)='poste',[txtCorps1] & ' ' & conjonction([Demande]) & ' ' & [Demande] & '.',[txtCorps1]) AS txtCorps, TblRepCandidat.txtCorps2, TblRepCandidat.txtCorps3 FROM (DonneesCandidatures LEFT JOIN TblRepCandidat ON DonneesCandidatures.Réponse = TblRepCandidat.TypeRéponse) LEFT JOIN TableFournInternet ON DonneesCandidatures.Fournisseur = TableFournInternet.Fournisseur;")
'Boucle sur chaque client et les ajoute au champ BCC du mail
While Not oRst1.EOF
'Crée un nouveau message
Set oMail = oApp.CreateItem(olMailItem)
oMail.Body = oRst1.Fields("txtcorps") & _
IIf(IsEmpty([txtCorps2]) = True, "", Chr(10) & oRst1.Fields("txtCorps2")) & _
IIf(IsEmpty([txtCorps3]) = True, "", Chr(10) & oRst1.Fields("txtCorps3"))
oMail.Subject = oRst1.Fields("strObjet") '& " du " & oRst0.Fields("dtCrea")
strTo = oRst1.Fields("Mail") & "; " 'strT1 & oRst1.Fields("Mail") & "; "
oRst1.MoveNext
'Supprime la dernière virgule
.olMail.Sender = olAcc.CurrentUser.AddressEntryoMail.To = Left(strTo, Len(strTo) - 2)
'Envoi du mail
oMail.Send
Wend
'oRst0.Close
oRst1.Close
Set oRst0 = Nothing
Set oRst1 = Nothing
Set oDB = Nothing
'Ferme Outlook
'oApp.Quit
Set oApp = Nothing
End Sub |
Partager