'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