Code to check if subject contains the receipt email address ( Validation)

[aravindhan_3]

Hi,

some of my team members sends out email to outside my office email address, domain address is @Arvind.com

just to avoid this, i have the below code which checks and prompts whether the user before then send.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim prompt As String
Dim strMsg As String


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


Set recips = Item.Recipients
For Each recip In recips
    Set pa = recip.PropertyAccessor
            If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@in.Arvind.com") = 0 Then
              If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@uk.Arvind.com") = 0 Then
                If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@ie.Arvind.com") = 0 Then
                 If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@Arvind.ie") = 0 Then
                 strMsg = strMsg & "   " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
                 End If
                End If
              End If
            End If
Next
For Each recip In recips
    Set pa = recip.PropertyAccessor
    If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@in.Arvind.com") = 0 Then
      If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@uk.Arvind.com") = 0 Then
       If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@ie.Arvind.com") = 0 Then
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@Arvind.ie") = 0 Then
       prompt = "This email will be sent outside of mydomain.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
        If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
         Cancel = True
         Exit Sub
         End If
        End If
       End If
      End If
    End If
    
 Next
End Su

but most of the time they have to send to outsiders as well, but they have to mention the name in subject line, and they miss it always. I would like to add one more condition to this, in case any of them sending an email to outsiders, they have to mention the domain name in subject line.

eg if any of them sending email to xxxx@vbaexpress.com
then they have to mention in the subject line - vbaexpress ( domain name)
if they miss it, a prompt message should come

Can anyone help with this

Regards
Arvind

[excelliot]

Hi use below code:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Dim prompt As String
    Dim strMsg As String
    Dim domain As String
  
     
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
     
     
    Set recips = Item.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@in.Arvind.com") = 0 Then
            If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@uk.Arvind.com") = 0 Then
                If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@ie.Arvind.com") = 0 Then
                    If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@Arvind.ie") = 0 Then
                        domain = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
                        domain = Split(domain, "@")(1)
                        domain = Replace(domain, "." & Right(domain, (Len(domain) - InStrRev(domain, "."))), "")
                            If InStr(Item.Subject, domain) = 0 Then
                                strMsg = strMsg & "   " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
                            End If
                    End If
                End If
            End If
        End If
    Next
    
    If strMsg <> "" Then
    prompt = "This email will be sent outside of mydomain.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
        If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
            Exit Sub
        End If
    End If
End Sub

So now you will prompted only if you miss domain name in Subject line..

Cheers!!

[aravindhan_3]

Hi,

Thanks for the code, this works, but its giving only one warning message,
can we change this to
1. If the to address is outside domain it has to give a warning "You are sending to outside domain do you want to proceed" anyways irrespective whether subject is entered or not
2. when click yes to proceed, then check if the subject contain the domain name, if its already there, send message.
If no,give a warning to edit the subject

Regards
Arvind

[excelliot]

Ok, check this..

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Dim prompt As String
    Dim strMsg As String, strMsg2 As String
    Dim domain As String
     
   
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    
    Set recips = Item.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@in.Arvind.com") = 0 Then
            If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@uk.Arvind.com") = 0 Then
                If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@ie.Arvind.com") = 0 Then
                    If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@Arvind.ie") = 0 Then
                            strMsg = strMsg & "   " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
                        domain = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
                        domain = Split(domain, "@")(1)
                        domain = Replace(domain, "." & Right(domain, (Len(domain) - InStrRev(domain, "."))), "")
                        If InStr(Item.Subject, domain) = 0 Then
                            strMsg2 = strMsg2 & "   " & domain & vbNewLine
                        End If
                    End If
                End If
            End If
        End If
    Next
     


    If strMsg <> "" Then
        prompt = "This email will be sent outside of mydomain.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
        If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
            Exit Sub
        End If
    End If
    
    If strMsg2 <> "" Then
        prompt = "This email does contain external domain name " & vbNewLine & "Kindly add domain name : " & vbNewLine & strMsg2 & vbNewLine & "in subject line to send this email."
        If MsgBox(prompt, vbOKOnly + vbMsgBoxSetForeground, "Check Domain NAme") = vbOK Then
            Cancel = True
            Exit Sub
        End If
    End If
    
End Sub

Cheers!!

[aravindhan_3]

Great!.. this worked.

thanks a lot

[excelliot]

Cool, Cheeers!!

[aravindhan_3]

Hi,

just realized one more problem, this one works perfectly fine when i sent individual emails to my suppliers.

some times i have to send a reminder to all the suppliers at one shot, in that case its asking me to enter all the domain names in subject? is there any better way to avoid this? or any other option that we do?
like if there are more than 1 domain names in to address, there should be any one of the works " Reminder or followup or note" in subject?
THanks