Exchange CDO - Messaging add-on

Here is a simple example of how you can add a message to your exchange client, before the message goes out, it is desogned to be a safety to allow the users to double check their recipients before the message goes out after hitting SEND. This function has become very crucial in the world of information security and compliance to protect date from being sent to the wrong recipients. Here is the code as an example, code has to be altered to work with your active directory LDAP and CDO 1.12 has to

'*'**************************************************************************************
' 
'   Project: Micrsoft Exchange Send options
'   Name   : VBA script
'   Author  : Prem Dhanendran
'
'****************************************************************************************
Dim obsession As MAPI.Session
Dim oAddressList As MAPI.AddressList
Dim oAddressEntries As MAPI.AddressEntries
Dim oAddressEntry As MAPI.AddressEntry
Dim oAddEntryFilter As AddressEntryFilter
Dim oMessage As MAPI.Message

Private Sub Application_ItemSend(ByVal mailItem As Object, Cancel As Boolean)
Set oSession = CreateObject("MAPI.Session")

oSession.Logon , , , False
Dim prompt As String
Dim prompt1 As String
On Error Resume Next

n = mailItem.Recipients.Count

'MsgBox (mailItem.Recipients.Count)
'prem2:
If n = 0 Then GoTo prem1
    ' Get address
    'If objAddressEntry = "" Then
    'MsgBox "No User Specified", vbOKOnly + vbExclamation, "User Search"
    'Exit Sub
    'Else

prem2:
               'If n = 0 Then GoTo prem1
               Set objAddressEntry = mailItem.Recipients.Item(n)
               Set oAddressList = oSession.GetAddressList(CdoAddressListGAL)
               Set oAddressEntries = oAddressList.AddressEntries
               Set oAddEntryFilter = oAddressEntries.Filter
               oAddEntryFilter.Name = objAddressEntry
               Set oAddressEntry = oAddressEntries.GetFirst
               On Error GoTo prem1
              'For i = 1 To 30
              'MsgBox (oAddressEntry.Fields(i, "i"))
              'Next
                            
              If InStr(1, oAddressEntry.Fields(7), "0") Then
               n = n - 1
               'MsgBox (n)
                'Set objAddressEntry = mailitem.recipients.Item(n + 1)
                  GoTo prem2
              Else
               prompt1 = "There is an external address or a personal contact/Group in " & vbCrLf & "TO: " & mailItem.To & vbCrLf & "CC: " & mailItem.CC & vbCrLf & "BCC:" & mailItem.BCC & vbCrLf & "Do you want to continue to send ?" & vbCrLf & "Note: All e-mails will be delayed by three minutes irrespective of the recipient's location."
                If MsgBox(prompt1, vbYesNo + vbQuestion + vbSystemModal, "Address check") = vbNo Then
                 GoTo prem
                 'If InStr(1, oAddressEntry.Fields(16), "TMCS") Then
                  'ElseIf oAddressEntries.Count > 1 Then

prem1:
            If oAddressEntries.Count < 1 Then
            'MsgBox "one or more of the e-mail address are not in the Address list", vbOKOnly, "Search"
              prompt = "There is either an external address or a personal contact/Group in the following" & vbCrLf & "TO: " & mailItem.To & vbCrLf & "CC: " & mailItem.CC & vbCrLf & "BCC:" & mailItem.BCC & vbCrLf & "Do you want to continue to send ?" & vbCrLf & vbCrLf & "Note: All e-mails will be delayed by three minutes irrespective of the recipient's location."
            If MsgBox(prompt, vbYesNo + vbQuestion + vbSystemModal, "Recipient e-mail Address check") = vbNo Then
             GoTo prem
            If InStr(1, mailItem.To, "@") Or InStr(1, mailItem.CC, "@") Or InStr(1, mailItem.BCC, "@") Then
             prompt2 = "This is an external E-mail.Do you want to send this e-mail to " & mailItem.To & ";" & mailItem.CC & ";" & mailItem.BCC & "?"
            If MsgBox(prompt2, vbYesNo + vbQuestion + vbSystemModal, "Send E-mail confirmation") = vbNo Then
             GoTo prem
             'Else
              'Set oAddressEntry = oAddressEntries.GetFirst
               'oAddressEntry.Fields
                'Set objAddressEntry = mailitem.recipients.Item(2)

prem4:
              Cancel = False
             
prem:
              Cancel = True
             
                     End If
                  End If
               End If
            End If
         End If
    End If
 
End Sub

Hope this helps someone.

Prem Dhanendran