Nosacīti neļaujiet programmai Outlook sūtīt e-pastu, pamatojoties uz sūtītāja un adresāta adresēm

Tas ļauj pārbaudīt e-pasta ziņojumus pēc adreses. Es nevaru pretendēt uz lielu kredītu, jo lielākoties vairāki dažādi kodi, kas publicēti tiešsaistē, ir apvienoti vienā. Neatkarīgi no tā, tas darbojas stabili un nogādās jūs pusceļā uz to, kur vēlaties būt. Tas tiek izmantots mūsu uzņēmumā, lai nosūtītu visus ārēji nosūtītos e-pastus uz publisko mapi HR atsauksmes.

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 = "[email protected]"
        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

Esmu modificējis kodu, lai tas būtu nedaudz vieglāk lasāms, faktiski tas pats kods, tikai nedaudz glītāks.

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