FAQ Outlook - Articles: R15350 [VBA] Choix du compte selon les destinataires

« Catégorie

Q15000 Macros - VBA (41)

Catégorie »

[<<] « Article

Article » [>>]

Permet de choisir entre différents COMPTES selon les destinataires.
Correspond au menu "Comptes" à coté de "Envoyer"

Function Set_Account(ByVal AccountName As String, M As Outlook.MailItem) As String

'Créée par Sue Mosher http://www.outlookcode.com/codedetail.aspx?id=889

'et modifiée par Oliv' pour OUTLOOK 2003

Dim OLI As Outlook.Inspector

Dim strAccountBtnName As String

Dim intLoc As Integer

Const ID_ACCOUNTS = 31224

Dim CBs As Office.CommandBars

Dim CBP As Office.CommandBarPopup

Dim MC As Office.CommandBarControl
Set OLI = M.GetInspector

If Not OLI Is Nothing Then

Set CBs = OLI.CommandBars
Set CBP = CBs.FindControl(, ID_ACCOUNTS)

CBP.Reset

If Not CBP Is Nothing Then

For Each MC In CBP.Controls

intLoc = InStr(MC.Caption, " ")

If intLoc > 0 Then

strAccountBtnName = Mid(MC.Caption, intLoc + 1)

Else

strAccountBtnName = MC.Caption

End If

If strAccountBtnName = AccountName Then

MC.Execute

Set_Account = AccountName

GoTo Exit_Function

End If

Set_Account = ""

Exit_Function:

Set MC = Nothing

Set CBP = Nothing

Set CBs = Nothing

Set OLI = Nothing

End Function

' SOIT en execution manuelle ou dans une macro

Private Sub test_account_easy()

Dim oitem As Outlook.MailItem
Set oitem = ActiveInspector.CurrentItem

MsgBox oitem.Recipients.Count & " destinataires"

Dim toto

'Ici on boucle sur tous les destinataires à la recherche de la concordance.

For Each toto In oitem.Recipients

If toto.Address Like "*mon@destinataire.fr*" Or toto.Address _
Like "*@destinataire.fr*" Then

ici = True

MsgBox toto.Address

Else:

ici = False

' on quitte la boucle si un seul ne concorde pas

Exit For

End If

Next toto

If Not ici = True Then

go = Set_Account("pop.easynet.fr", oitem)

Else

go = Set_Account("Serveur Microsoft Exchange", oitem)

End If

End Sub

'Soit en Automatique à l'envoi

Private Sub Application_ItemSend(ByVal Item AS Object, Cancel As Boolean)
Dim toto

'Ici on boucle sur tous les destinataires à la recherche de la concordance.

For Each toto In Item.Recipients

'Si un destinataire correspond on quitte la boucle et applique le compte

If toto.Address Like "*mon@destinataire.fr*" Then

ici = True

Exit for

Else:

ici = False

End If

Next toto

If Not ici = True Then

go = Set_Account("pop.easynet.fr", Item)

Else

go = Set_Account("Serveur Microsoft Exchange", Item)

End If

End Sub

Articles

Catégories

R06032 Utiliser l'archivage automatique avec les dates de réception

Q06000 Les fichiers d'Outlook

R15045 [VBA] Ouvrir l'arborescence des pst contenant une boîte de réception

Q15000 Macros - VBA

R15930 [VBA] Création de menu dans outlook

Q15000 Macros - VBA

R17070 VSTO et les formulaires d'Outlook 2007

Q17000 Formulaires

R15380 [VBA] Envoi via VBA : suppression de la confirmation d'envoi

Q15000 Macros - VBA