Envoi Mail via Lotus problème avec Attachment

Set AttachME = MailDoc.CREATERICHTEXTITEM("CheminFichier")
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", CheminFichier, "CheminFichier")
MailDoc.CREATERICHTEXTITEM ("CheminFichier")

        Set AttachME = MailDoc.CreateRichTextItem("Attachment")
        Set EmbedObj = AttachME.EmbedObject(1454, "", Chemin & "\" & File1, "Attachment")
 
        Set AttachMEA = MailDoc.CreateRichTextItem("AttachmentA")
        Set EmbedObjA = AttachMEA.EmbedObject(1454, "", Chemin & "\" & File2, "AttachmentA")
 
        Set AttachMEB = MailDoc.CreateRichTextItem("AttachmentB")
        Set EmbedObjB = AttachMEB.EmbedObject(1454, "", Chemin & "\" & File3, "AttachmentB")
 
        Set AttachMEC = MailDoc.CreateRichTextItem("AttachmentC")
        Set EmbedObjC = AttachMEC.EmbedObject(1454, "", Chemin & "\" & File4, "AttachmentC")

Public Sub EnvoiMailLocal(Fichier As String, CheminFichier As String)
Dim UserName As String     'Le nom d'utilisateur
Dim oSession As Object     'La session Notes
Dim DataBase As Object     'La base des mails
Dim DataBaseName As String 'Le nom de la base des mails
Dim Document As Object     'Le mail
Dim DocTexte As Object     'Le corps du message
Dim ObjetDiv As Object     'Sert pour Div object

On Error GoTo ErreurNET

' init données source
Dim Sujet As String, Message As String, Password As String
Dim AdresExpediteur As String, AdresDestinataire As String
Dim AdresDestinataireCC As String, AdresDestinataireBCC As String
AdresExpediteur = Sheets(NomDeLaFeuilData$).Range("Data_CellAdresExpediteur")
AdresDestinataire = Sheets(NomDeLaFeuilData$).Range("Data_CellAdresDestinataire")
AdresDestinataireCC = Sheets(NomDeLaFeuilData$).Range("Data_CellAdresDestinataireCC")
AdresDestinataireBCC = Sheets(NomDeLaFeuilData$).Range("Data_CellAdresDestinataireBCC")
Sujet = Sheets(NomDeLaFeuilData$).Range("Data_CellSujet")
Message = Sheets(NomDeLaFeuilData$).Range("Data_CellMessage")

' Crée la session
Set oSession = CreateObject("Notes.NotesSession")

' Ouvre la session (base des mails) (récupère nom utilisateur)
UserName = oSession.UserName
DataBaseName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set DataBase = oSession.GetDataBase("", DataBaseName)
If Not DataBase.IsOpen Then DataBase.OpenMail

' Crée le document et définit l'élement(DocTexte) rajouté au message
Set Document = DataBase.CreateDocument
Set DocTexte = Document.CreateRichTextItem("Body")

' Adresses destinataires
Document.Form = "Memo"
Document.Sendto = AdresDestinataire
If AdresDestinataireCC > "" Then Document.CopyTo = AdresDestinataireCC
If AdresDestinataireBCC > "" Then Document.BlindCopyTo = AdresDestinataireBCC
Document.Subject = Sujet

' Corps du message
With DocTexte
 .AppendText "Bonjour,"
 .AddNewLine 2
 .AppendText Message
 .AddNewLine 1
'.AppendText "..."
'.AddNewLine 2
'.AppendText "Eric"
'.AddNewLine 1
End With

' Fichier joint
If CheminFichier <> "" Then Set ObjetDiv = DocTexte.EmbedObject(1454, "", CheminFichier, "")
'Voir si problème !?
'If CheminFichier <> "" Then Call DocTexte.EmbedObject(1454, "", CheminFichier, "")
'ou  encore  !?
'If CheminFichier <> "" Then Set ObjetDiv = Document.EmbedObject(1454, "", CheminFichier, "")
'ou  encore  !?
'If CheminFichier <> "" Then Call Document.EmbedObject(1454, "", CheminFichier, "")

'--Envoi du Mail ----------------
Document.SaveMessageOnSend = True
Document.PostedDate = Now()
'Document.ReturnReceipt = "1"
Document.Send 0, AdresDestinataire
GoTo FinMail '------- fin --------

'---------
ErreurNET:
Msg$ = "Erreur " & Err.Source & "  No " & Err.Number & vbLf & vbLf & Err.Description
T$ = "Envoi Mail: Problème de connexion !?"
MsgBox Msg$, vbCritical, T$, Err.HelpFile, Err.HelpContext
'suite fin

FinMail:
Set oSession = Nothing
Set DataBase = Nothing
Set Document = Nothing
Set DocTexte = Nothing
Set ObjetDiv = Nothing
'Set dbDirectory = Nothing
On Error GoTo 0: Err.Clear
End Sub

If CheminFichier <> "" Then
   Set AttachME = Document.CreateRichTextItem("Attachment")
   Set ObjetDiv = AttachME.EmbedObject(1454, "", CheminFichier, "Attachment")
End If

' --------- Envoi d'un mail avec Lotus Notes ---------- .
'Ajouter la référence Lotus Domino Objects (domobj.tlb) .
'Cocher Référence  [x]Lotus Domino Objects              .
'Sujet                : sujet du mail                   .
'AdresDestinataire    : destinataire principal          .
'AdresDestinataireCC  : destinataire en copie           .
'AdresDestinataireBCC : destinataire en copie invisible .
'Message              : message                         .
'CheminEtFichier      : pièce jointe chemin complet     .

'######### ici quand j'appel EnvoiMailLocal je passe le Chemin Et le Fichier (C:\Temp\MonFichier.xls)
Public Sub EnvoiMailLocal(CheminEtFichier As String)
'Dim DataBase As NotesDatabase
'Dim oSession As NotesSession
'Dim dbDirectory As NotesDbDirectory
Dim oSession As Object     'CreateObject("Notes.NotesSession")
Dim UserName As String     'Nom d'utilisateur
Dim DataBase As Object     'Base des mails
Dim DataBaseName As String 'Nom de la base
Dim Document As Object     'Mail
Dim DocTexte As Object     'Msg élément rajouté
Dim AttachME As Object     'Pièce jointe en RTF
Dim AttachF1 As Object     '1' pièce attachée
'Dim AttachF2 As Object    '2'
'Dim AttachF3 As Object    '3'

On Error GoTo ErreurNET: Err.Clear '*****

' init données source
Dim Sujet As String, Message As String, Password As String
Dim AdresExpediteur As String, AdresDestinataire As String
Dim AdresDestinataireCC As String, AdresDestinataireBCC As String
'############## MES ADRESSES SONT DANS DES CELLULES A ADAPTER ###################
AdresExpediteur = Sheets(NomDeLaFeuilData$).Range("Data_CellAdresExpediteur")
AdresDestinataire = Sheets(NomDeLaFeuilData$).Range("Data_CellAdresDestinataire")
AdresDestinataireCC = Sheets(NomDeLaFeuilData$).Range("Data_CellAdresDestinataireCC")
AdresDestinataireBCC = Sheets(NomDeLaFeuilData$).Range("Data_CellAdresDestinataireBCC")
Sujet = Sheets(NomDeLaFeuilData$).Range("Data_CellSujet")
'############## ICI DANS MA FEUILLE J'AI UNE ZONE TEXTE POUR MON MESSAGE A ADAPTER ###################
On Error Resume Next: Err.Clear '*****
Message = Sheets(NomDeLaFeuilData$).Shapes("ZoneTexteMessage").TextFrame.Characters.Text
If Err Then
   On Error GoTo ErreurNET: Err.Clear '*****
   Message = Sheets(NomDeLaFeuilData$).Range("Data_CellMessage")
End If
Do
 Message = Trim(Message): LenMsg = Len(Message): If LenMsg = 0 Then Exit Do
 If Right(Message, 1) = Chr(10) Then Message = Left(Message, LenMsg - 1) Else Exit Do
Loop
'#####################################################################################################

On Error GoTo ErreurNET: Err.Clear '*****

' Crée la session
Set oSession = CreateObject("Notes.NotesSession")
'Call oSession.Initialize(Password) 'ligne réservée aux versions 5.x et supérieur

' Récupère nom d'utilisateur
UserName = oSession.UserName
DataBaseName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"

' Ouvre la base des mails (si fermé, ouvre et demande le password)
Set DataBase = oSession.GetDataBase("", DataBaseName)
If Not DataBase.IsOpen Then DataBase.OpenMail
' Ouvre la base des mails en utilisant le serveur par défaut
'Set dbDirectory = oSession.GetDbDirectory("??????????????")
'Set DataBase = dbDirectory.OpenMailDatabase

' Adresses destinataires
Set Document = DataBase.CreateDocument ' crée le document
Document.Form = "Memo"
Document.Sendto = AdresDestinataire
If AdresDestinataireCC > "" Then Document.CopyTo = AdresDestinataireCC
If AdresDestinataireBCC > "" Then Document.BlindCopyTo = AdresDestinataireBCC
Document.Subject = Sujet
' Message (voir aussi ci-dessous)
Document.Body = Message
' Message multiligne
'Set DocTexte = Document.CreateRichTextItem("Body") ' crée le corps du texte
'With DocTexte
' .AppendText "Bonjour,"
' .AddNewLine 2
' .AppendText "message"
' .AddNewLine 2
' .AppendText "Eric"
'End With
   
'  1'Fichier joint
If CheminEtFichier <> "" Then
   Set AttachME = Document.CreateRichTextItem("Attachment")
   Set AttachF1 = AttachME.EmbedObject(1454, "", CheminEtFichier, "Attachment")
End If
'  2'Fichier joint . . .
'If CheminEtFichier2 <> "" Then
'   Set AttachME = Document.CreateRichTextItem("Attachment2")
'   Set AttachF2 = AttachME.EmbedObject(1454, "", CheminEtFichier2, "Attachment2")
'End If

'------ Envoi le Mail ------------
Document.SaveMessageOnSend = True 'True svg dans les courriers envoyés
Document.PostedDate = Now()
Document.Send 0, AdresDestinataire
GoTo FinMail '------- fin --------

'---------
ErreurNET:
Msg$ = "Erreur " & Err.Source & "  No " & Err.Number & vbLf & vbLf & Err.Description
T$ = "Envoi Mail: Problème de connexion !?"
MsgBox Msg$, vbCritical, T$, Err.HelpFile, Err.HelpContext
'suite fin

FinMail:
Set oSession = Nothing
Set DataBase = Nothing
Set Document = Nothing
Set DocTexte = Nothing
Set AttachME = Nothing
Set AttachF1 = Nothing
'Set AttachF2 = Nothing
'Set AttachF3 = Nothing
'Set dbDirectory = Nothing
On Error GoTo 0: Err.Clear
End Sub