Blocking email id's

[baigm]

Hi All

Need some support on the out look. I have a list of top people
Whom we should never send email.
To avoid this, is there any vba code which can be added to outlook macro
And a sender can never send email to these people.

Its very difficult ti monitor this manually. As we have 15 20 people
Who are sending customer emails.

Regards
Baig

[skatonni]

A standard method is to check addresses while in ItemSend. One solution could look like this.


Private Sub Application_ItemSend_test()
Dim currItem As mailItem
Set currItem = CreateItem(0)
currItem.Subject = "test"
currItem.To = "dummy1ATsomewhere.com; allowableATsomewhere.com"
currItem.Recipients.ResolveAll
currItem.Display
Application_ItemSend currItem, False
End Sub

Private Sub Application_ItemSend(ByVal Item As mailItem, Cancel As Boolean)
' Put code in the ThisOutlookSession module
' Checks the recipients on an outgoing email
Dim strAddress As String
Dim strSearchNamesFound As String
Dim objRecipient As Recipient
Dim longFound As Long
Dim longButtons As Long
Dim i As Long

' Array to hold addresses of forbidden recipients
Dim strSearchArray() As String
Dim arraySize As Long

' Only two names in this example
arraySize = 2
ReDim strSearchArray(arraySize)
strSearchArray(1) = "dummy1ATsomewhere.com"
strSearchArray(2) = "dummy2ATsomewhere.com"

For Each objRecipient In Item.Recipients

strAddress = objRecipient.Address

' ***************************************
' To see the address as Outlook sees it.
' Replace the dummy text in the array of addresses.
Debug.Print "Address: " & strAddress
' ***************************************

For i = 1 To arraySize ' The number of entries in strSearchArray

longFound = InStr(1, strAddress, strSearchArray(i), vbTextCompare)
If longFound > 0 Then
strSearchNamesFound = strSearchNamesFound & strSearchArray(i) & vbCr & vbCr
End If

Next i
Next objRecipient

If strSearchNamesFound <> "" Then

Cancel = True

longButtons = vbOKOnly + vbSystemModal + vbMsgBoxSetForeground

strSearchNamesFound = "Forbidden recipient(s) found. Send is cancelled." & _
vbCr & vbCr & strSearchNamesFound

MsgBox strSearchNamesFound, longButtons

Debug.Print strSearchNamesFound

End If

ExitRoutine:
Set objRecipient = Nothing

End Sub

[baigm]

Hi Thanks for the above coding, I have copy pasted the same in Thisoutooksession

when I tried to change the currItem.To = "allowableATsomewhere.com"

and strSearchArray(1) = "dummy1ATsomewhere.com"

and try send email to the above address, getting an error as

"Procedure declaration does not match description of event or procedure having the same name"

Can you please check, help

Regard
Baigm

[skatonni]

Found this line should say Item As Object


Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

[baigm]

Hi Skatonni,

thanks, I changed the line but the mail still going through to the ID I mentioned in the coding, please check the below, and advise if anything missing

Private Sub Application_ItemSend_test()
Dim currItem As MailItem
Set currItem = CreateItem(0)
currItem.Subject = "test"
currItem.To = "baigAT123.com; allowableATsomewhere.com"
currItem.Recipients.ResolveAll
currItem.Display
Application_ItemSend currItem, False
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' Put code in the ThisOutlookSession module
' Checks the recipients on an outgoing email
Dim strAddress As String
Dim strSearchNamesFound As String
Dim objRecipient As Recipient
Dim longFound As Long
Dim longButtons As Long
Dim i As Long

' Array to hold addresses of forbidden recipients
Dim strSearchArray() As String
Dim arraySize As Long

' Only two names in this example
arraySize = 2
ReDim strSearchArray(arraySize)
strSearchArray(1) = "baigAT123.com"
strSearchArray(2) = "BaigAT123.com"

For Each objRecipient In Item.Recipients

strAddress = objRecipient.Address

' ***************************************
' To see the address as Outlook sees it.
' Replace the dummy text in the array of addresses.
Debug.Print "baigAT123.com " & strAddress
' ***************************************

For i = 1 To arraySize ' The number of entries in strSearchArray

longFound = InStr(1, strAddress, strSearchArray(i), vbTextCompare)
If longFound > 0 Then
strSearchNamesFound = strSearchNamesFound & strSearchArray(i) & vbCr & vbCr
End If

Next i
Next objRecipient

If strSearchNamesFound <> "" Then

Cancel = True

longButtons = vbOKOnly + vbSystemModal + vbMsgBoxSetForeground

strSearchNamesFound = "Forbidden recipient(s) found. Send is cancelled." & _
vbCr & vbCr & strSearchNamesFound

MsgBox strSearchNamesFound, longButtons

Debug.Print strSearchNamesFound

End If

ExitRoutine:
Set objRecipient = Nothing

End Sub

[skatonni]

To debug, mouse-click anywhere in the "Sub Application_ItemSend_test" code. Press F8 repeatedly to step through the code. http://www.cpearson.com/excel/DebuggingVBA.aspx

[clickrudra]

Hello Dear..

check the email address you are mentioning in the array... if it is exchange email address outlook will not read it like a real email ID (someoneATdomaindotcom), Hence try using the debug.print command to see how the outlook is reading email ids you have updated.. i used the code and it worked for me..

Best Regards