Alerte Outlook VBA — Documentation Technique

1

Activer l'onglet Développeur

Pour accéder à l'éditeur VBA, vous devez d'abord afficher l'onglet Développeur dans le ruban Outlook. Suivez le chemin ci-dessous :

📁

Fichier

Menu principal Outlook

⚙️

Options

Paramètres du logiciel

🎛️

Personnaliser le ruban

Gestion des onglets

✅

Cocher "Développeur"

Activer l'onglet

ℹ️

Navigation Fichier > Options > Personnaliser le ruban > Cocher Développeur dans la liste de droite, puis valider avec OK.

2

Activer toutes les macros

Pour que le script VBA puisse s'exécuter, les macros doivent être autorisées. Depuis l'onglet Développeur nouvellement apparu :

⚠️

Sécurité Activer toutes les macros permet à n'importe quel script VBA de s'exécuter dans Outlook. N'utilisez cette option que dans un environnement de confiance et maîtrisé.

ℹ️

Navigation Onglet Développeur > Paramètres des macros > Sélectionner Activer toutes les macros, puis valider.

3

Copier le script dans Visual Basic

Ouvrez l'éditeur Visual Basic depuis l'onglet Développeur, puis collez le script dans le bon module :

ℹ️

Navigation Onglet Développeur > Visual Basic > Dans l'arborescence à gauche, double-cliquer sur ThisOutlookSession > Coller le code du script > Sauvegarder (Ctrl+S).

⚠️

Important Le code doit impérativement être collé dans ThisOutlookSession et non dans un Module standard, sinon l'événement Application_ItemSend ne se déclenchera pas.

4

Script VBA complet

Voici le script complet à copier dans ThisOutlookSession. Il détecte les destinataires externes et ceux d'un autre service, et affiche une alerte avant l'envoi.

vba

'==========================================================
' SCRIPT : Alerte destinataires externes / autre service
' VERSION : 2.0 - Stable
'==========================================================

Option Explicit

Const MON_DOMAINE As String = "@xxx.xx"

Const GROUPE_MON_SERVICE As String = "xx"

'==========================================================
' EVENEMENT : Déclenché avant l'envoi d'un mail
'==========================================================
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    If Item.Class <> olMail Then Exit Sub

    Dim objMail         As Outlook.MailItem
    Dim objRecipient    As Outlook.recipient
    Dim strAddress      As String
    Dim intStatus       As Integer

    Dim bExterne        As Boolean
    Dim bAutreService   As Boolean
    Dim strListeExt     As String
    Dim strListeService As String
    Dim strMsg          As String

    bExterne = False
    bAutreService = False
    strListeExt = ""
    strListeService = ""

    Set objMail = Item

    Dim i As Integer
    For i = 1 To objMail.Recipients.Count

        Set objRecipient = objMail.Recipients.Item(i)
        strAddress = GetSmtpAddress(objRecipient)

        If strAddress = "" Then GoTo Suite

        If IsWhitelisted(strAddress) Then GoTo Suite

        intStatus = GetRecipientStatus(objRecipient, strAddress)

        Select Case intStatus
            Case 2
                bExterne = True
                strListeExt = strListeExt & "  • " & objRecipient.Name & vbCrLf

            Case 1
                bAutreService = True
                strListeService = strListeService & "  • " & objRecipient.Name & vbCrLf

            Case 0
        End Select

Suite:
    Next i

    If bExterne Or bAutreService Then

        strMsg = "ATTENTION - Vérifiez vos destinataires !" & vbCrLf & vbCrLf

        If bExterne Then
            strMsg = strMsg & "DESTINATAIRE(S) EXTERNE(S) :" & vbCrLf
            strMsg = strMsg & strListeExt & vbCrLf
        End If

        If bAutreService Then
            strMsg = strMsg & "DESTINATAIRE(S) AUTRE SERVICE :" & vbCrLf
            strMsg = strMsg & strListeService & vbCrLf
        End If

        strMsg = strMsg & vbCrLf & "Voulez-vous quand même envoyer ce mail ?"

        Dim intReponse As Integer
        intReponse = MsgBox(strMsg, vbYesNo + vbExclamation, "Alerte sécurité envoi mail")

        If intReponse = vbNo Then
            Cancel = True
        End If

    End If

End Sub

'==========================================================
' FONCTION : Détermine le statut d'un destinataire
' Retourne :
'   0 = Même service
'   1 = Autre service (même domaine)
'   2 = Externe
'==========================================================
Private Function GetRecipientStatus(objRecipient As Outlook.recipient, _
                                    strAddress As String) As Integer

    GetRecipientStatus = 2

    If InStr(LCase(strAddress), LCase(MON_DOMAINE)) = 0 Then
        GetRecipientStatus = 2
        Exit Function
    End If

    Dim objEntry    As Outlook.AddressEntry
    Dim objExUser   As Outlook.ExchangeUser

    Set objEntry = objRecipient.AddressEntry

    On Error Resume Next
    Set objExUser = objEntry.GetExchangeUser()
    On Error GoTo 0

    If objExUser Is Nothing Then

        GetRecipientStatus = 1
        Exit Function
    End If

    If IsMemberOfGroup(objExUser, GROUPE_MON_SERVICE) Then
        GetRecipientStatus = 0
    Else
        GetRecipientStatus = 1
    End If

End Function

'==========================================================
' FONCTION : Vérifie si un utilisateur est dans le même
'            service via son DN dans l'AD
'==========================================================
Private Function IsMemberOfGroup(objUser As Outlook.ExchangeUser, _
                                 strGroupName As String) As Boolean

    IsMemberOfGroup = False

    Dim strDN As String

    On Error Resume Next
    strDN = objUser.PropertyAccessor.GetProperty( _
            "http://schemas.microsoft.com/mapi/proptag/0x3A20001E")
    On Error GoTo 0

    If strDN = "" Then
        IsMemberOfGroup = False
        Exit Function
    End If

    If InStr(LCase(strDN), LCase(strGroupName)) > 0 Then
        IsMemberOfGroup = True
    End If

End Function

'==========================================================
' FONCTION : Récupère l'adresse SMTP réelle
'==========================================================
Private Function GetSmtpAddress(objRecipient As Outlook.recipient) As String

    GetSmtpAddress = ""

    Dim objEntry    As Outlook.AddressEntry
    Dim objExUser   As Outlook.ExchangeUser
    Dim strAddr     As String

    Set objEntry = objRecipient.AddressEntry

    If objEntry.Type = "SMTP" Then
        GetSmtpAddress = LCase(Trim(objEntry.Address))

    ElseIf objEntry.Type = "EX" Then
        On Error Resume Next
        Set objExUser = objEntry.GetExchangeUser()
        On Error GoTo 0

        If Not objExUser Is Nothing Then
            strAddr = objExUser.PrimarySmtpAddress
            GetSmtpAddress = LCase(Trim(strAddr))
        End If
    End If

End Function

'==========================================================
' FONCTION : Vérifie si une adresse est en liste blanche
'==========================================================
Private Function IsWhitelisted(strAddress As String) As Boolean

    IsWhitelisted = False

    Dim strList As String
    strList = "xxx-*|xxx-*"

    Dim arrWhitelist()  As String
    Dim strEntry        As String
    Dim strPrefixe      As String
    Dim i               As Integer

    arrWhitelist = Split(strList, "|")
    strAddress = LCase(Trim(strAddress))

    For i = 0 To UBound(arrWhitelist)
        strEntry = LCase(Trim(arrWhitelist(i)))

        If Left(strEntry, 1) = "@" Then
            If InStr(strAddress, strEntry) > 0 Then
                IsWhitelisted = True
                Exit Function
            End If
        ElseIf Right(strEntry, 1) = "*" Then
            strPrefixe = Left(strEntry, Len(strEntry) - 1)
            If Left(strAddress, Len(strPrefixe)) = strPrefixe Then
                IsWhitelisted = True
                Exit Function
            End If
        Else
            If strAddress = strEntry Then
                IsWhitelisted = True
                Exit Function
            End If
        End If

    Next i

End Function

5

Paramétrer le script

Après avoir collé le script, vous devez modifier les trois valeurs suivantes pour l'adapter à votre environnement. Ces lignes se trouvent en haut du script et dans la fonction IsWhitelisted.

1 — Définir votre nom de domaine :

vba

Const MON_DOMAINE As String = "@xxx.xx"  '  <-- modifier avec votre nom de domaine

ℹ️

Remplacez @xxx.xx par votre domaine e-mail d'entreprise, par exemple @monentreprise.fr. Tout destinataire ne contenant pas ce domaine sera considéré comme externe.

2 — Définir votre service dans l'Active Directory :

vba

Const GROUPE_MON_SERVICE As String = "xx"  '  <-- modifier avec le nom de votre OU dans l'AD

ℹ️

Remplacez xx par le nom de votre Unité Organisationnelle (OU) dans l'Active Directory. Si vous avez plusieurs services sur le même domaine, cela permet de distinguer les destinataires de votre propre service des autres.

3 — Configurer la liste blanche :

vba

strList = "xxx-*|xxx-*"  '  <-- adresses à mettre en liste blanche, séparées par |

ℹ️

Les adresses de la liste blanche ne déclenchent jamais d'alerte. Plusieurs formats sont supportés :
• @domaine.fr — exclut tout un domaine
• expediteur-* — exclut toutes les adresses commençant par ce préfixe (wildcard *)
• contact@domaine.fr — exclut une adresse exacte
Séparez chaque entrée avec le caractère |

✅

Installation terminée Une fois les trois valeurs modifiées et le fichier sauvegardé (Ctrl+S), fermez et relancez Outlook. Le script s'activera automatiquement à chaque envoi de mail.

Alerte destinatairesOutlook VBA

Activer l'onglet Développeur

Activer toutes les macros

Copier le script dans Visual Basic

Script VBA complet

Paramétrer le script

Alerte destinataires
Outlook VBA