Envoi de fichier avec mail CDO

[L.Lemarchand]

Bonjour,

J'utilise le code suivant pour envoyer des emails depuis access.

Mon problème :
Quand j'envoi un fichier en pièce joint, les destinataires le recoivent en plusieurs exemplaires (1 pour le 1er, 2 pour le 2e...).
Je pense que je dois initialiser les paramètres du mail avant l'envoi du suivant mais je ne sais pas comment faire.

Merci de m'aider

[L.Lemarchand]

Function Mailing_Mail(Objet As String, Texte As String, Signataire As String, Expediteur As String, Optional Fichier As String)

Dim strSujet As String
Dim strMsg As String
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim cdo_message As New CDO.Message
Dim Compte As Integer

Compte = 0

Set cdo_message.Configuration = GetSMTPServerConfig()

' Ouverture de la requête_mail
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM [R_F_RCHENT2_Envoi] WHERE NOT IsNull(REP_Mail);", cnn

' Envoi d'un e-mail par personne
While Not rst.EOF

' Constitution du message personnalisé
If IsNull(rst("COR_Nom")) Then
strMsg = "Monsieur," & vbCrLf & vbCrLf & Texte & vbCrLf & vbCrLf & Signataire
Else
strMsg = rst("COR_Civilite") & " " & rst("COR_Nom") & vbCrLf & vbCrLf & Texte & vbCrLf & vbCrLf & Signataire
End If

With cdo_message
.To = rst("REP_Mail")
.From = Expediteur
.Subject = Objet
.TextBody = strMsg
If Fichier <> "" Then .AddAttachment (Fichier)
'.GetStream.SaveToFile "C:\MonMail.txt", adSaveCreateOverWrite
.Send
End With

' Mail suivant
Compte = Compte + 1
rst.MoveNext
Wend

'Copie du mesage à l'expéditeur
With cdo_message
.To = Expediteur
.From = Expediteur
.Subject = Objet
.TextBody = strMsg
.Send
End With

'Information utilisateur
MsgBox ("Nombre de mail envoyé : " & Compte)

'Libération des objets
Set cdo_message = Nothing
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing

End Function