Empêcher conditionnellement Outlook d'envoyer un courrier électronique en fonction des adresses de destinataire et de destinataire

Question

J'ai plusieurs comptes de messagerie installés dans Outlook 2007 (par exemple, johndoe@domainA.com, johndoe@domainB.com, etc.). À l'occasion, généralement à la suite de la fonction Auto Complete, je vais envoyer par erreur un courriel de johndoe@domainA.com à un destinataire qui ne devrait recevoir que du courrier de johndoe@domainB.com).

Ces restrictions entre les adresses électroniques de (mon compte de messagerie sélectionné) et de destinataire (vers ou CC) peuvent généralement être définies par nom de domaine. Par exemple, johndoe@domainA.com ne doit pas envoyer à recipient-domainX.com & recipient-domainY.com. Et johndoe@domainB.com ne doit pas envoyer à recipient-domain1.com & recipient-domain2.com. Donc, il serait bien de définir explicitement ou de "coder" ces restrictions de domaine par compte de messagerie dans un script VBA ou un fichier texte. Puis comment, en utilisant VBA ou d'autres moyens, puis-je implémenter une vérification des adresses e-mail, pour empêcher un e-mail d'être envoyé si l'une de ces restrictions est violée.

Ouvert à d'autres solutions plus élégantes.

Merci.

Answer 1

Ceci vous permet de filtrer les emails par adresse. Je ne peux pas réclamer beaucoup de crédit pour cela, c'est en grande partie plusieurs codes différents postés en ligne fusionnés en un seul. Peu importe, cela fonctionne solide et devrait vous aider à mi-chemin où vous voulez être. Ceci est utilisé dans notre société pour envoyer tous les e-mails envoyés en externe dans un dossier public HR reviews.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 
    If Item.Class <> olMail Then Exit Sub 
    Dim objMail As MailItem 
    Set objMail = Item 
    Dim NotInternal As Boolean 
    NotInternal = False 
    Dim objRecip As Recipient 
    Dim objTo As Object 
    Dim str As String 
    Dim res As Integer 
    Dim strBcc As String 
    On Error Resume Next 
    Const PidTagSmtpAddress As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" 
    Dim i As Integer 
    Dim objRecipColl As Recipients 
    Set objRecipColl = objMail.Recipients 
    Dim objOneRecip As Recipient 
    Dim objProp As PropertyAccessor 
    For i = 1 To objRecipColl.Count Step 1 
     Set objOneRecip = objRecipColl.Item(i) 
     Set objProp = objOneRecip.PropertyAccessor 
     str = objProp.GetProperty(PidTagSmtpAddress) 
     If Len(str) >= 17 Then 'Len of email address screened. 
      If UCase(Right(str, 17)) <> "@COMPANYEMAIL.COM" Then NotInternal = True 
     Else 
      NotInternal = True 
     End If 
    Next 
    If NotInternal = True Then 
     strBcc = "HRExternalEmails@COMPANYEMAIL.com" 
     Set objRecip = objMail.Recipients.Add(strBcc) 
     objRecip.Type = olBCC 
      If Not objRecip.Resolve Then 
       strMsg = "Could not resolve the Bcc recipient. " & _ 
         "Do you still want to send the message?" 
       res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _ 
         "Could Not Resolve Bcc Recipient") 
       If res = vbNo Then 
        Cancel = True 
       End If 
      End If 
    End If 
    Set objRecipColl = Nothing 
    Set objRecip = Nothing 
    Set objOneRecip = Nothing 
    Set objMail = Nothing 
    Set objTo = Nothing 
    Set oPA = Nothing 
End Sub 

Answer 2

J'ai modifié le code pour être légèrement plus facile à lire, effectivement le même code un peu plus propre.

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

If Item.Class <> olMail Then Exit Sub 

Dim sCompanyDomain As String: sCompanyDomain = "companydomain.com" 

Const PidTagSmtpAddress As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" 

On Error Resume Next 
Dim oMail As MailItem: Set oMail = Item 
Dim oRecipients As Recipients: Set oRecipients = oMail.Recipients 
Dim bDisplayMsgBox As Boolean: bDisplayMsgBox = False 

Dim sExternalAddresses As String 
Dim oRecipient As Recipient 

For Each oRecipient In oRecipients 

    Dim oProperties As PropertyAccessor: Set oProperties = oRecipient.PropertyAccessor 
    Dim smtpAddress As String: smtpAddress = oProperties.GetProperty(PidTagSmtpAddress) 

    Debug.Print smtpAddress 

    If (Len(smtpAddress) >= Len(sCompanyDomain)) Then 

     If (Right(LCase(smtpAddress), Len(sCompanyDomain)) <> sCompanyDomain) Then 

      ' external address found 
      If (sExternalAddresses = "") Then 

       sExternalAddresses = smtpAddress 

      Else 

       sExternalAddresses = sExternalAddresses & ", " & smtpAddress 

      End If 

      bDisplayMsgBox = True 

     End If 

    End If 

Next 

If (bDisplayMsgBox) Then 

    Dim iAnswer As Integer 
    iAnswer = MsgBox("You are about to send this email externally to " & sExternalAddresses & vbCr & vbCr & "Do you want to continue?", vbExclamation + vbYesNo, "External Email Check") 

    If (iAnswer = vbNo) Then 
     Cancel = True 
    End If 

End If 

End Sub