Check Recipients, notify if sending to specified domain

[blewett]

I'm trying to figure out how to give a warning if a message is being sent to a specific domain.

I'm working off of the answer provided by Jimmy Pena here: stackoverflow.com/a/9106314 (I'm too new to post a link, but everything you need is there)

(I know this code is for a specific address and not a domain, but I can't even get to the second part of the problem)

The code provided there is:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim msg As Outlook.MailItem
Dim recips As Outlook.Recipients
Dim str As String
Dim prompt As String

Set msg = GetMailItem
Set recips = msg.Recipients

str = "me@anywhere.com"
For x = 1 To GetRecipientsCount(recips)
str1 = recips(x)
If str1 = str Then
MsgBox str1, vbOKOnly, str1
prompt = "Are you sure you want to send to " & str1 & "?"
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
Cancel = True
End If
End If
Next x
End Sub

Public Function GetRecipientsCount(itm As Variant) As Long
' pass in a qualifying item, or a Recipients Collection
Dim obj As Object
Dim recips As Outlook.Recipients
Dim types() As String
types = Split("MailItem,AppointmentItem,JournalItem,MeetingItem,TaskItem", ",")
Select Case True
' these items have a Recipients collection
Case UBound(Filter(types, TypeName(itm))) > -1
Set obj = itm
Set recips = obj.Recipients
Case TypeName(itm) = "Recipients"
Set recips = itm
End Select

GetRecipientsCount = recips.Count
End Function

I have left it unchanged except for the email address to look for.

When sending an email I get an "Object required" error at Set msg = GetMailItem. Debug shows Msg and recips as Nothing and GetMailItem as Empty.

Once I get past issue #1 (i.e. get the thing to run) I intend to modify this to search for a domain instead of a specific address. I intend to use
If InStr(str1, "example.com") > 0 Then instead of
If str1 = str Then. Will that get me where I'm trying to go?

Any help is appreciated

[skatonni]

You missed some code

http://www.jpsoftwaretech.com/working-with-the-outlook-recipients-collection-in-vba/

Function GetMailItem() As Outlook.mailItem

On Error Resume Next

Select Case TypeName(Application.ActiveWindow)
Case "Explorer"

If TypeName(ActiveExplorer.selection.Item(1)) = "MailItem" Then
Set GetMailItem = ActiveExplorer.selection.Item(1)
End If

Case "Inspector"

If TypeName(ActiveInspector.currentItem) = "MailItem" Then
Set GetMailItem = ActiveInspector.currentItem
End If
End Select
On Error GoTo 0
End Function


As for the enhancement:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' http://www.vbaexpress.com/forum/showthread.php?t=42692
Dim Msg As Outlook.mailItem
Dim recips As Outlook.Recipients

Dim str As String
Dim str1 As String

Dim prompt As String

Dim x As Long

Set Msg = GetMailItem
Set recips = Msg.Recipients

str = "domainname.com"

For x = 1 To GetRecipientsCount(recips)

str1 = recips(x)

Debug.Print str1 & " / " & recips(x).Address

If InStr(recips(x).Address, str) > 0 Then

prompt = "Are you sure you want to send to:" & vbCr & str1 & " / " & recips(x).Address & "?"

If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
Cancel = True
End If

End If
Next x
End Sub

[blewett]

Of course that worked.:banghead: Thanks so much.