word/outlook 2013 publipostage sous un autre nom [ resolue]

'modèle qui sera recherché dans le sujet du mail où * contient l'adresse mail de "envoyé de la part de"
'exemple de sujet de mail valide : "bla bla bla {SentOnBehalfOf:adresse@mail.fr}"
Private Const Pattern_SentOnBehalfOf As String = "{SentOnBehalfOf:*}"


Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim leftPart As String, rightPart As String, mailAddr As String
    
    If Item.Class = olMail Then
        'contrôler si le sujet contient le pattern
         If Item.Subject Like "*" & Pattern_SentOnBehalfOf & "*" Then
            
            'décomposer la construction du pattern et récupérer l'adresse mail
             leftPart = Left(Pattern_SentOnBehalfOf, InStr(Pattern_SentOnBehalfOf, "*") - 1)
            rightPart = Mid(Pattern_SentOnBehalfOf, InStr(Pattern_SentOnBehalfOf, "*") + 1, 9 ^ 9)
            
            mailAddr = Right(Item.Subject, Len(Item.Subject) - InStr(Item.Subject, leftPart) - Len(leftPart) + 1)
            mailAddr = Left(mailAddr, Len(mailAddr) - Len(rightPart))
            
            'supprimer le sujet du mail (enlever le pattern)
             Item.Subject = Replace(Item.Subject, leftPart & mailAddr & rightPart, vbNullString)
            
            'modifier le "envoyer de la part de" du mail avec l'adresse mailAddr
             '...
             '...
             '...
             MsgBox "Adresse mail : """ & mailAddr & """.", vbInformation, "Info"
            
            'Sauver les modifications
             Item.Save

        End If
    End If
End Sub

Sub Test()
Dim mItem As MailItem

    Set mItem = Application.CreateItem(olMailItem)
    With mItem
        .Subject = "ddd"
        .Body = "sdgfsdg"
        .SentOnBehalfOfName = "blabla@tutu.com"
        .Display
    End With
End Sub

Option Explicit

Sub EnvoiAutomatiqueMail()
  Dim OutlookApp As Object, OutlookMail As Object
  Dim Exped$, strbody$, i&
  'Si Outlook n'est pas ouvert
  If OutlookOuvert = False Then i = Shell("Outlook", vbNormalNoFocus)
  'Suivant les lignes de ton tableau
  For i = 2 To [A65536].End(3).Row
    'Choix du vendeur et de son adresse mail
    Select Case Cells(i, 2)
      Case "clark": Exped = "clark.zzzz@orange.fr"
      Case "Bruce": Exped = "Bruce.xxxx@orange.fr"
      Case "Oliver": Exped = "Oliver.yyyy@orange.fr"
    End Select
  Set OutlookApp = CreateObject("Outlook.Application")
  Set OutlookMail = OutlookApp.CreateItem(0)
    strbody = "Bonjour " & Cells(i, 1) & "," & Chr(13) & _
         "Merci de faire affaire avec nous," & Chr(13) & _
         "Cette année vous avez acheté pour " & Cells(i, 3) & Chr(13) & _
         "Merci," & Chr(13) & Chr(13) & Cells(i, 2) & Chr(13) & "mailto:" & Exped
    On Error Resume Next
    With OutlookMail
      'Choisir l'adresse d'envoi
      .SentOnBehalfOfName = Exped
      .Subject = "CA"
      .To = Cells(i, 4)
      .Body = strbody
      .Display 'pour voir
      '.Send 'pour envoyer
    End With
  'recommence la procedure pour la ligne suivante
  Next i
End Sub
Function OutlookOuvert() As Boolean
Dim oOL As Object
  On Error Resume Next
  Set oOL = GetObject(, "Outlook.Application")
  On Error GoTo 0
  OutlookOuvert = Not (oOL Is Nothing)
  Set oOL = Nothing
End Function

Option Explicit

Sub EnvoiAutomatiqueMail()
  Dim OutlookApp As Object, OutlookMail As Object
  Dim SigString$, Signature$, MaSignature$
  Dim Exped$, strbody$, i&
  'Si Outlook n'est pas ouvert
  If OutlookOuvert = False Then i = Shell("Outlook", vbNormalNoFocus)
  'Suivant les lignes de ton tableau
  For i = 2 To [A65536].End(3).Row
    'Choix du vendeur et de son adresse mail
    Select Case Cells(i, 2)
      Case "clark": Exped = "clark.zzzz@orange.fr"
      Case "Bruce": Exped = "Bruce.xxxx@orange.fr"
      Case "Oliver": Exped = "Oliver.yyyy@orange.fr"
    End Select
    
  ' recupere la signature outlook, definis à qui envoyer, l'objet et ajoute la signature outlook au corps du mail "strbody"
  MaSignature = Cells(i, 2) & ".htm"
  'Normalement l'emplacement est dans AppData\Microsoft\Signatures\
  SigString = Environ("appdata") & "\Microsoft\Signatures\" & MaSignature
  'Vérification de la présence de la signature dans le répertoire
  If Dir(SigString) <> "" Then
    Signature = GetBoiler(SigString)
   Else
    Signature = ""
  End If
    
  Set OutlookApp = CreateObject("Outlook.Application")
  Set OutlookMail = OutlookApp.CreateItem(0)
    strbody = "Bonjour " & Cells(i, 1) & ",<BR>" & _
         "Merci de faire affaire avec nous,<BR><BR>" & Chr(13) & _
         "Cette année vous avez acheté pour " & Cells(i, 3) & "<BR>" & _
         "Merci,<BR><BR>" & Cells(i, 2) & "<BR>" & Signature
    On Error Resume Next
    With OutlookMail
      'Choisir l'adresse d'envoi
      .SentOnBehalfOfName = Exped
      .Subject = "CA"
      .To = Cells(i, 4)
      .HTMLBody = strbody
      .Display 'pour voir
      '.Send 'pour envoyer
    End With
  'recommence la procedure pour la ligne suivante
  Next i
End Sub
Function OutlookOuvert() As Boolean
Dim oOL As Object
  On Error Resume Next
  Set oOL = GetObject(, "Outlook.Application")
  On Error GoTo 0
  OutlookOuvert = Not (oOL Is Nothing)
  Set oOL = Nothing
End Function
Function GetBoiler(ByVal sFile As String) As String
  'Dick Kusleika
  Dim fso As Object
  Dim ts As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
  GetBoiler = ts.readall
  ts.Close
End Function