'=========================================================================================================================
'A useful script that can verify recipients address list(including CC/BCC), to avoid unexpected addresses being interfused.
'Change the value of "strKeyword" below to your email domain name.
'e.g. if you set strKeyword = "abc.com", all email sendings will be warned unless the adrees contains "abc.com".
'V1.2012-12 the initial version
'V2.2013-1  added the ability to check grouped adresses, no deepness limit.
'V3.2013-2  added Outlook 2010/2013 compatibility, now can work with Outlook 2007/2010/2013.(2003 has not been tested.)
'http://www.youtube.com/user/akimamax2
'http://mycsharp.seesaa.net/
'=========================================================================================================================

'Public Variables declaration area, used by the whole script range.
Public strKeyword As String
Public strMsgAddr As String
'Dim intCount As Integer
Public strDomains As String
Public flag As Integer
Public flagDomain As Integer

'Event will be triggered by pushing Send email button.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
strKeyword = "MyEmailDomain.com" 'Change this value to your email domain.
flag = 0
flagDomain = 0
strMsgAddr = ""
strDomains = ""

'Check every recipient
        For i = 1 To Item.Recipients.Count
           Set recp = Item.Recipients.Item(i)
              


CheckRecp:
        
        On Error Resume Next
        If recp.DisplayType = olUser Then
        CheckAddrString recp.Address, strKeyword
        End If
        
        On Error Resume Next
        If recp.DisplayType = olPrivateDistList Then
        For j = 1 To recp.AddressEntry.Members.Count
        CheckAddressEntry recp.AddressEntry.Members.Item(j)
        Next
        End If
        GoTo Persue
CheckKeyword:
        CheckAddrString recp.Address, strKeyword
        Resume Next
Persue:
        Next

   
'Make response according to the checking process, then wait for user's decision.
If flag > 0 Then
Dim Msg, Style, Title, Response, MyString
Msg = "[ " + Str(flag) + " ] unexpected adress(es) found, which contain [ " + Str(flagDomain) + " ] domain(s). " + vbCrLf + "Are you sure you want to send this email right now?" + vbCrLf + "*******Domain List*******" + vbCrLf + strDomains + vbCrLf + "*******Adress List*******" + vbCrLf + strMsgAddr
Style = vbYesNo + vbDefaultButton2   '
Title = "Address Checker"

Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then
Cancel = True

End If

End If

End Sub

'A standalone function for checking AddressEntry(different to Recipient, so cannot process them togther from the very begainning)
Private Function CheckAddressEntry(AddrEntry As AddressEntry)

If AddrEntry.DisplayType = olUser Then
   CheckAddrString AddrEntry.Address, strKeyword
End If

If AddrEntry.DisplayType = olPrivateDistList Then
    
   For i = 1 To AddrEntry.Members.Count
   'Using recursion because you don't know how deep the adress group could be.
   CheckAddressEntry AddrEntry.Members.Item(i)
   
   Next
  

End If


End Function

'A standalong function for string determining, operate the public variables directly.
Private Function CheckAddrString(addr As String, keyword As String)
            If InStr(addr, keyword) = 0 Then
            flag = flag + 1
            strMsgAddr = strMsgAddr + addr + vbCrLf
            Dim dom As String
            dom = Mid(addr, InStr(addr, "@"), Len(addr))
               If InStr(strDomains, dom) <= 0 Then
                  strDomains = strDomains + dom + vbCrLf
                  flagDomain = flagDomain + 1
               End If
            End If
End Function