If email not sent to specific user

[Thomas [PBD]]

I am attempting to write a macro... or locate a rule that when an email comes
in from a specific person with a specific subject line to check to see if a
specific person is either in copy or in the To line of the email. If the
person is not in the To or Copy line, then I want the email forwarded to that
person.

I write code in Excel and Access constantly, but this would be the first
time in Outlook.

I dont really know where to start because after looking at other coding, it
seems that I would have to specific to look in Outlook then at emails then at
a specific email then at the To line or CC line etc in order to find this.
Any help would be extremely appreciated on this matter.

 

[JP]

This should work. Simply edit the "specific person" and "specific
subject" to your taste.

1. Place this in ThisOutlookSession module:

Private WithEvents Items As Outlook.Items

2. In your "Application_Startup" event, this code:

Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items

(if you don't already have a Startup event, simply paste "Private Sub
Application_Startup()" into ThisOutlookSession first, then paste the
code above.)

3. Paste this code into ThisOutlookSession:

Private Sub Items_ItemAdd(ByVal Item As Object)

If TypeOf Item Is Outlook.MailItem Then
Dim Msg as Outlook.Mailitem
Dim NewFwd as Outlook.Mailitem
Dim sRecip as Outlook.Recipient
Set Msg = Item

If Msg.SenderName = "specific person" Then
If Msg.Subject = "specific subject" Then
For each sRecip in Msg.Recipients
If sRecip.Name = "other specific person" Then
Set NewFwd = Msg.Forward
NewFwd.Recipients.Add("other specific person").Type = olTo
NewFwd.Display ' or .Send
End if
Next sRecip
End If
End If

End If

Set NewFwd = Nothing
Set Msg = Nothing

End Sub


HTH,
JP

 

[JP]

Sorry, just realized my code will forward the email if the person IS
in the recipient list, not if they are NOT in the recipient list.

You could amend the code as such

counter = 0
For each sRecip in Msg.Recipients
If sRecip.Name = "other specific person" Then
Exit For ' they were sent the email, we can safely exit
Else
counter = counter + 1
end if
Next sRecip

If counter = Msg.Recipients.Count Then ' we cycled through
each recipient and did not find this one
Set NewFwd = Msg.Forward
NewFwd.Recipients.Add("other specific person").Type = olTo
NewFwd.Display ' or .Send
End if


HTH,
JP

 

[Thomas [PBD]]

Therefore, the ThisOutlookSession Module should read:

Private WithEvents Items As Outlook.Items
-----------------------------------------------------------------
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
------------------------------------------------------------------
Private Sub Items_ItemAdd(ByVal Item As Object)

If TypeOf Item Is Outlook.MailItem Then
Dim Msg As Outlook.MailItem
Dim NewFwd As Outlook.MailItem
Dim sRecip As Outlook.Recipient
Set Msg = Item

If Msg.SenderName = "specific person" Then
If Msg.Subject = "specific subject" Then
For Each sRecip In Msg.Recipients
If sRecip.Name = "other specific person" Then
Set NewFwd = Msg.Forward
NewFwd.Recipients.Add("other specific person").Type = olTo
NewFwd.Display ' or .Send
End If
Next sRecip
End If
End If

End If

Set NewFwd = Nothing
Set Msg = Nothing

End Sub

 

[Thomas [PBD]]

Therefore, the ThisOutlookSession Module should read:

Private WithEvents Items As Outlook.Items
-----------------------------------------------------------------
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
------------------------------------------------------------------
Private Sub Items_ItemAdd(ByVal Item As Object)

If TypeOf Item Is Outlook.MailItem Then
Dim Msg As Outlook.MailItem
Dim NewFwd As Outlook.MailItem
Dim sRecip As Outlook.Recipient
Set Msg = Item

If Msg.SenderName = "specific person" Then
If Msg.Subject = "specific subject" Then
For Each sRecip In Msg.Recipients
counter = 0
For each sRecip in Msg.Recipients
If sRecip.Name = "other specific person" Then
Exit For ' they were sent the email, we can safely exit
Else
counter = counter + 1
end if
Next sRecip

If counter = Msg.Recipients.Count Then ' we cycled through each
recipient and did not find this one
Set NewFwd = Msg.Forward
NewFwd.Recipients.Add("other specific person").Type = olTo
NewFwd.Display ' or .Send
End if
Next sRecip
End If
End If

End If

Set NewFwd = Nothing
Set Msg = Nothing

End Sub

 

[JP]

Remove the first "For Each sRecip In Msg.Recipients", it looks like it
was duplicated. Also change "Exit For" to "Exit Sub", or add an error
handler to go straight to the end of the code where the object
variables are released.


HTH,
--JP