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 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
| Private Sub Envoi_Mails_Click()
'Déclarations obligatoires et préalables
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim spathFichier As String
Dim sdestinataire As String
Dim sNomFichier As String
Dim rs As Recordset
Dim objoutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim outlook_aw As String
Dim outlook_aww As String
Dim outlook_ch As String
Dim outlook_chw As String
Dim REP As String
Dim i As Integer
Dim k As Integer
Dim outlook_ctr As Integer
Dim outlook_ctr_ch As Integer
Dim prem_dest As String
'Variable locale
Dim Numero As Integer
Dim destinataire As String
'Dim Objet As String
Dim sw_ok As String
Dim nom_fichier As String
Dim sw_dest As Integer
'Variables qui placent le recordset en mémoire vive
Set db = Application.CurrentDb
Set rs1 = db.OpenRecordset("Select * from T_Mails_Clients")
'Logiquement Access doit commencer par traiter le 1er enregistrement
'Mais il est préférable de s'en assurer
rs1.MoveFirst
'Ici, débute la boucle
Do
'recherche de la présence d'un fichier excell
sw_ok = "no"
Me.code_emet = rs1.Fields("numero")
nom_fichier = rs1.Fields("numero") & ".xls"
Me.nom_destinataire = rs1.Fields("destinataire")
GoSub recherche_fichier
If sw_ok = "yes" Then
'On injecte le contenu du champ dans une variable
'Numero = rs1("Numero")
'destinataire = rs1("destinataire")
GoSub outlook_ouvert
' Crée la session Outlook.
Set objoutlook = CreateObject("Outlook.Application")
' Crée le message.
Set objOutlookMsg = objoutlook.CreateItem(olMailItem)
With objOutlookMsg
' Ajoute le(s) destinataire(s) au message.
If IsNull(Me.nom_destinataire) = True Or Me.nom_destinataire = "" Then
Else
i = 1
Do
outlook_aww = Left(Me.nom_destinataire, Len(Me.nom_destinataire))
outlook_ctr = InStr(i, outlook_aww, ";") - 1
outlook_aw = Mid(outlook_aww, i, (outlook_ctr - i) + 1)
Set objOutlookRecip = .Recipients.Add(outlook_aw)
objOutlookRecip.Type = olTo
i = outlook_ctr + 2
Loop Until i >= Len(outlook_aww)
' Définit l'objet, le corps et la priorité du message.
.Subject = rs1.Fields("object") 'Determine l'objet du mail
.Body = "Bonjour," & vbCrLf & vbCrLf & "" _
& "Veuillez trouver ci-joint le fichier du Mois." & vbCrLf & vbCrLf & "" _
& "Cordialement," & vbCrLf & vbCrLf & "" _
& "SAV. Tel 01 02 03 04 05" & Chr(10) & Chr(10) & Chr(10) & "" _
& "SAVDELABOITE@machin.fr" & Chr(10) & Chr(10) & Chr(10)
.Importance = olImportanceHigh 'Haute
' Ajoute des pièces jointes au message.
' outlook_aww = Left(Me.outlook_attach, Len(Me.outlook_attach))
' outlook_ch = Me.outlook_chemin
' outlook_ctr = InStr(i, outlook_aww, ";") - 1
' outlook_ctr_ch = InStr(k, outlook_ch, ";") - 1
' outlook_aw = Mid(outlook_aww, i, (outlook_ctr - i) + 1)
' outlook_chw = Mid(outlook_ch, k, (outlook_ctr_ch - k) + 1)
Set objOutlookAttach = .Attachments.Add(Me.chemin_stock & nom_fichier)
.Send
Cancel = True
End If
End With
End If
Set objOutlookMsg = Nothing
Set objoutlook = Nothing
'On passe à l'enregistrement suivant
rs1.MoveNext
'Et ceci jusqu'à la fin du recordset
Loop Until rs1.EOF = True
MsgBox "L'envoi des Mails est terminé"
Exit Sub
outlook_ouvert:
On Error Resume Next
Dim Ol_App As Outlook.Application
Dim stappname As String
Set Ol_App = GetObject(, "Outlook.Application")
If Ol_App Is Nothing Then
stappname = Me.chemin_outlook
Call Shell(stappname, 2)
End If
Set Ol_App = Nothing
Return
recherche_fichier:
With Application.FileDialog(msoFileDialogOpen)
Dim doc_cheminw As String
doc_cheminw = Me.chemin_stock & "*.xls"
retour = Dir(doc_cheminw, vbNormal)
While retour <> ""
If retour <> "" Then
If retour = nom_fichier Then
sw_ok = "yes"
Return
End If
End If
retour = Dir()
Wend
' MsgBox retour
End With
Return
End Sub |
Partager