Promt Warning List External Users, on VB Script to checks for external users

Hello All,
i have the following VB Script,
It checks for external users and promts for a confirmation if it detects any email that is not listed on the domains,

Code:

---

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objMail As Outlook.MailItem
    Dim objRecipients As Outlook.Recipients
    Dim i As Long
    Dim strRecipientAddress As String
    Dim strPrompt As String
    Dim nWarning As Integer
 
    If TypeOf Item Is MailItem Then
      Set objMail = Item
      Set objRecipients = objMail.Recipients
 
      For i = objRecipients.Count To 1 Step -1
          strRecipientAddress = objRecipients.Item(i).Address
          'Change @example.com to your own company domain
          If InStr(LCase(strRecipientAddress), "@my1Domain.com") <= 0 Then
          If InStr(LCase(strRecipientAddress), "@my2Domain.com") <= 0 Then
          If InStr(LCase(strRecipientAddress), "@my3Domain.com") <= 0 Then
          If InStr(LCase(strRecipientAddress), "@my4Domain.com") <= 0 Then
          If InStr(LCase(strRecipientAddress), "@my5Domain.com") <= 0 Then
          Else
              Cancel = False
          End If
          End If
          End If
          End If
          End If
         
      Next
     
        strPrompt = "Are you sure to send this email to outside your company? "
        nWarning = MsgBox(strPrompt, vbYesNo + vbQuestion, "Confirm Email to Outside Organization")
        If nWarning = vbNo Then
            Cancel = True
        End If
      End If
End Sub

---

Actually in this way everything works just fine,
but i would like to modify the Promt, i would like to list all the external users on the Promt of the confirmation.,
is this possible to be integrated on this script?

Please note that i found a lot of bugs on using the following,

Code:

---

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

---

So what i'm looking for is an alternative of this.


Thank you in advance for the support.

you should use a select case inplace of all the if statements

try like

Code:

---

For i = 1 To objRecipients.Count    ' no need to step backwards as you are not removing items from the collection
strRecipientAddress = objRecipients.Item(i).Address
domain = Mid(strRecipientAddress, InStr(s, "@"))
  Select Case domain
    Case "@my1Domain.com", "@my2Domain.com", "@my3Domain.com", "@my4Domain.com", "@my5Domain.com"
    Case Else:    rejects = rejects & vbNewLine & strRecipientAddress
  End Select

Next

---

any one not in the listed domains will be added to the reject list, then include the reject list in your prompt
if the reject list is empty then all recipients are within the company domains and no need for prompt

Hello westconn1,
thanks for the suggestion,
following the code on your suggestion is failing and the debug stops on

Code:

---

domain = Mid(strRecipientAddress, InStr(s, "@"))

---

Any suggestions?

Code:

---

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objMail As Outlook.MailItem
    Dim objRecipients As Outlook.Recipients
    Dim i As Long
    Dim strRecipientAddress As String
    Dim strPrompt As String
 
    If TypeOf Item Is MailItem Then
      Set objMail = Item
      Set objRecipients = objMail.Recipients
 
      For i = 1 To objRecipients.Count    ' no need to step backwards as you are not removing items from the collection
            strRecipientAddress = objRecipients.Item(i).Address
            domain = Mid(strRecipientAddress, InStr(s, "@"))
           
        Select Case domain
            Case "@my1domain.com", "@my2domain.com", "@my3domain.com", "@my4domain.com", "@my5domain.com"
            Case Else:    rejects = rejects & vbNewLine & strRecipientAddress
        End Select
      Next
       
        If rejects <> "" Then
          strPrompt = "This email will be sent outside of the company to:" & vbNewLine & strRecipientAddress & vbNewLine & "Please check recipient address." & vbNewLine & vbNewLine & "Do you still wish to send?"
            If MsgBox(strPrompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
        End If
        End If
    End If
End Sub

---

Thanks in advance.

did you define the varaible?

as you did not specify what error this is just a guess

You have an InStr(s,"@")

What is "s"?

EDIT:
btw: If you just want to grab the domain of an EMail-Address....

Code:

---

Dim sAddress As String
Dim arrTemp() As String
Dim sDomain As String
   
    sAddress = "[email protected]"
   
    If InStrRev(sAddress, "@") Then
   
        arrTemp = Split(sAddress, "@")
        sDomain = arrTemp(UBound(arrTemp))
   
    End If

---

or shorter

Code:

---

Dim sAddress As String
Dim sDomain As String
   
    sAddress = "[email protected]"
   
    If InStrRev(sAddress, "@") Then
   
        sDomain = Split(sAddress, "@")(1)
   
    End If

---

Of course, that way you have to change your Select Case to check without the @-sign (or you prepend the @-sign to the result(s))

That was the suggested sollution by westconn1,

Following the full code.
Probably i missed something, could you please update it in case i missed any variable here?

Code:

---

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objMail As Outlook.MailItem
    Dim objRecipients As Outlook.Recipients
    Dim i As Long
    Dim strRecipientAddress As String
    Dim strPrompt As String
 
    If TypeOf Item Is MailItem Then
      Set objMail = Item
      Set objRecipients = objMail.Recipients
 
      For i = 1 To objRecipients.Count    ' no need to step backwards as you are not removing items from the collection
            strRecipientAddress = objRecipients.Item(i).Address
            domain = Mid(strRecipientAddress, InStr(s, "@"))
           
        Select Case domain
            Case "@my1domain.com", "@my2domain.com", "@my3domain.com", "@my4domain.com", "@my5domain.com"
            Case Else:    rejects = rejects & vbNewLine & strRecipientAddress
        End Select
      Next
       
        If rejects <> "" Then
          strPrompt = "This email will be sent outside of the company to:" & vbNewLine & strRecipientAddress & vbNewLine & "Please check recipient address." & vbNewLine & vbNewLine & "Do you still wish to send?"
            If MsgBox(strPrompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
        End If
        End If
    End If
End Sub

---

Quote:

---

Originally Posted by charli1

That was the suggested sollution by westconn1,

Following the full code.
Probably i missed something, could you please update it in case i missed any variable here?

vb Code:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objMail As Outlook.MailItem
    Dim objRecipients As Outlook.Recipients
    Dim i As Long
    Dim strRecipientAddress As String
    Dim strPrompt As String
 
    If TypeOf Item Is MailItem Then
       Set objMail = Item
       Set objRecipients = objMail.Recipients
 
       For i = 1 To objRecipients.Count     ' no need to step backwards as you are not removing items from the collection
            strRecipientAddress = objRecipients.Item(i).Address
            domain = Mid(strRecipientAddress, InStr(s, "@"))
            
        Select Case domain
            Case "@my1domain.com", "@my2domain.com", "@my3domain.com", "@my4domain.com", "@my5domain.com"
            Case Else:     rejects = rejects & vbNewLine & strRecipientAddress
        End Select
      Next
         
         If rejects <> "" Then
          strPrompt = "This email will be sent outside of the company to:" & vbNewLine & strRecipientAddress & vbNewLine & "Please check recipient address." & vbNewLine & vbNewLine & "Do you still wish to send?"
            If MsgBox(strPrompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
         End If
        End If
    End If
End Sub

---

Your Problem is in Line 14 the InStr(s, "@")
you don't assign a value to "s"
at a guess: that "s" should be strRecipientAddress

OK so it should be

Code:

---

Dim s  As Long

---

or

Code:

---

Dim s As String

---

Thank you.

OK, so it should be?

Code:

---

Dim s  As Long

---

or

Code:

---

Dim s As String

---

Thank you.

Neither!

Code:

---

Dim sAddress As String
Dim sDomain As String

    sAddress = "[email protected]"
    sDomain = Mid(sAddress, InStr(sAddress, "@"))

---

Code:

---

domain = Mid(strRecipientAddress, InStr(strRecipientAddress, "@"))

---

sorry i posted in a rush before work, thought i had fixed all my temps

should have been, as pointed out by zvoni

Code:

---

For i = 1 To objRecipients.Count    ' no need to step backwards as you are not removing items from the collection
strRecipientAddress = objRecipients.Item(i).Address
domain = Mid(strRecipientAddress, InStr(strRecipientAddress, "@"))
  Select Case domain
    Case "@my1Domain.com", "@my2Domain.com", "@my3Domain.com", "@my4Domain.com", "@my5Domain.com"
    Case Else:    rejects = rejects & vbNewLine & strRecipientAddress
  End Select

Next

---

no need for s variable at all, i just used it to test i got the correct results before posting, i changed it in some places, but missed the one

Pete,

btw: I'd rather use InStrRev instead of InStr in your solution.
Just in case some jokster thinks an Address like "MyName@[email protected]" is funny.....

But i admit: It's been a long time since i've read the RFC for valid E-Mail-Addresses

Hi

I use this for saving attachments from particular Email-addresses in the Inbox

it checks the SenderName with Like

Code:

---

Public Function SaveAttachments()
    Dim myFolderName As String
    Dim objPosteingang As MAPIFolder
    Dim objNewMail As MailItem
    Dim Anzahl As Long
   
    Dim i As Long
    On Error Resume Next
    Set objPosteingang = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    For Each objNewMail In objPosteingang.Items
        With objNewMail
            'only Save Attachments if Post is New
            If .UnRead = True Then
           
            'get only Attachments from :
            If .SenderName Like "[email protected]" Or _
                    .SenderName Like "[email protected]" Then
                Anzahl = .Attachments.Count
           
                If Anzahl > 0 Then
                'create the Folder to save to:
                    myFolderName = "C:\Labor\" & objNewMail.SenderName & Space(4) & objNewMail.ConversationTopic
                    MkDir myFolderName
                    For i = 1 To Anzahl
                        .Attachments.Item(i).SaveAsFile myFolderName & "\" & .Attachments.Item(i).FileName
                    Next i
                End If
            End If
            End If
        End With
    Next objNewMail
Set objPosteingang = Nothing
Set objNewMail = Nothing
End Function

---

regards
Chris

Still stuck at this line,

Code:

---

domain = Mid(strRecipientAddress, InStr(strRecipientAddress, "@"))

---

following the full code.

Code:

---

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objMail As Outlook.MailItem
    Dim objRecipients As Outlook.Recipients
    Dim i As Long
    Dim strRecipientAddress As String
    Dim strPrompt As String
        Dim Address As String
        Dim domain As String
       
    If TypeOf Item Is MailItem Then
      Set objMail = Item
      Set objRecipients = objMail.Recipients
 
      For i = 1 To objRecipients.Count    ' no need to step backwards as you are not removing items from the collection
                        strRecipientAddress = objRecipients.Item(i).Address
                        domain = Mid(strRecipientAddress, InStr(strRecipientAddress, "@"))
                        Select Case domain
                        Case "@my1Domain.com", "@my2Domain.com", "@my3Domain.com", "@my4Domain.com", "@my4Domain.com"
                        Case Else:    rejects = rejects & vbNewLine & strRecipientAddress
                        End Select

                Next
       
        If rejects <> "" Then
          strPrompt = "This email will be sent outside of the company to:" & vbNewLine & strRecipientAddress & vbNewLine & "Please check recipient address." & vbNewLine & vbNewLine & "Do you still wish to send?"
            If MsgBox(strPrompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
        End If
        End If
    End If
End Sub

---

Quote:

---

Still stuck at this line,

---

you still did not post what the error is

see post #4 first line

Quote:

---

Originally Posted by westconn1

you still did not post what the error is

see post #4 first line

---

Hi westconn1,
sorry about that,
The error im facing is in italian language,

http://i67.tinypic.com/1z39ykw.png

And if i click on debug, the pop window VB editor on the line
http://i65.tinypic.com/iyonja.png

Runtime-Error 5 translates to "Invalid Procedure-Call" (or similiar - i have german VBA)
What's the Value of strRecipientAddress?
What's the Return-Value of the InStr-Call?
The only reason i know why Mid should fail is if InStr returns 0

Hello Zvoni,
well the value of the

Code:

---

strRecipientAddress

---

is 0, but why it is 0 i dont know, i have multiple external domain emails on my test.
but if i change the

Code:

---

Mid

---

in

Code:

---

Right

---

or

Code:

---

Left

---

the script works fine.
Any clue on this?

Look at my Post #7:
Insert between Line 13 and 14 a "Debug.Print strRecipientAddress".
What's the value?
If it's empty then there is something wrong with your Collection

It doesn't print nothing.

Found the issue,
the actual script cannot extract the email address of the EX email formats,
i just tested excluding the exchange email, and inserting recipients in SMTP mail formats the script works fine.
How can i fix this to correctly extract the EX email formats?

i do not have access to an exchange server account, but there are many examples in a google search

i found https://answers.microsoft.com/en-us/...b81c9ecd1?db=5 which has a function that should be able to do what you want