I'm trying to forward emails from my company's Outlook to an email account outside of our company. I have been given the ok to do this.
I'd like to forward any email that contains "Excel Friday" in the subject line.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If Msg.Subject = "Excel Friday" Then
Dim myMail As Outlook.MailItem
Set myMail = Msg.Reply
myMail.To = "xxxxxx#fakemail.com"
myMail.Display
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I'd like to forward any email that contains "Excel Friday" in the subject line to another email address.
But in the code you check for the exact match of the subject line:
If Msg.Subject = "Excel Friday" Then
Instead you need to look for a substring. To find the position of a substring in a string, use Instr function.
If Instr(Msg.Subject, "Excel Friday") Then
Also I have noticed that you use the Reply method:
Set myMail = Msg.Reply
Use the Forward method instead:
Set myMail = Msg.Forward
And then use the Send method.
myMail.Recipients.Add "Eugene Astafiev"
myMail.Send
Be aware, the code is based on the ItemAdd event handler. This event is not fired when a large number of items are added to the folder at once (more than 16).
You can do this using a Run a Script rule
Sub ChangeSubjectForward(Item As Outlook.MailItem)
Item.Subject = "Test"
Item.Save
Set olForward = Item.Forward
olForward.Recipients.Add "Jasonfish11#domain.com"
olForward.Send
End Sub
If a vba you can run on all messages in a folder at any time.
Paste into ThisOutlookSession and run
Sub ChangeSubjectThenSend()
Dim olApp As Outlook.Application
Dim aItem As Object
Set olApp = CreateObject("Outlook.Application")
Set mail = olApp.ActiveExplorer.CurrentFolder
For Each aItem In mail.Items
aItem.Subject = "New Subject"
aItem.Save
Set olForward = aItem.Forward
olForward.Recipients.Add "Jasonfish11#domain.com"
olForward.Send
Next aItem
End Sub
source Link
Related
I'm attempting to move email with specific subject when received.
The mail is still in my Inbox. I've tested by sending mail from my account with specific subject.
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Set myInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
If TypeName(item) = "MailItem" Then
Set Msg = item
If InStr(0, Msg.Subject, "Testing Subject", vbTextCompare) > 0 Then
Set fldr = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("Testing")
Msg.Move fldr
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I created this macro in ThisOutlookSession.
I think you may have an error with the naming of your Sub which means it doesn't fire
Items_ItemAdd => inboxItems_ItemAdd
As an addendum: I recently implemented a RegEx filter to incoming e-mails as I found I couldn't easily use rules to filter out some junk e-mail coming my way. This should be able to adapted to your needs (I've added the rule I think should work for you, but it's untested)
Within the 'ThisOutlookSession'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
On Error Resume Next
Call RegExFilterRules(EntryIDCollection)
End Sub
Within a module
Sub RegExFilterRules(ItemID As String)
' Requires Reference: Microsoft Scripting Runtime
Dim ThisNamespace As Outlook.NameSpace: Set ThisNamespace = Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = ThisNamespace.GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = ThisNamespace.GetDefaultFolder(olFolderJunk)
Dim oMsg As Outlook.MailItem: Set oMsg = ThisNamespace.GetItemFromID(ItemID, Inbox.StoreID)
If Not oMsg Is Nothing And oMsg.Class = olMail Then
'If FindPattern(oMsg.Subject, "^M\d+$") Then oMsg.Move Junk ' oMsg.Delete
If FindPattern(oMsg.Subject, "^Testing Subject") Then oMsg.Move Inbox.Folders("Testing")
End If
End Sub
Private Function FindPattern(Str As String, Pattern As String) As Boolean
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.RegExp")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = Pattern
FindPattern = .Test(Str)
End With
End Function
I pieced this together for saving all Excel attachments from incoming mail to a local drive folder.
It is in the ThisOutlookSession module and I restarted Outlook.
When I send a test email meeting the criteria in the If statements, I receive >"Error 438: Object doesn't support this property or method".
I can't figure out which object doesn't support which property or method.
It is at least running up to my If statements because this only happens to emails that meet the criteria.
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim i As Integer
Dim strFolder As String
Dim mySaveName As String
Dim myExt As String
Dim OlMail As Outlook.MailItem
strFolder = "D:\Scripts\VendorProductivity\Daily files"
If TypeName(Item) = "MailItem" Then
If Item.Subject Like "*Report*" Then
If Item.Recipient = "Jane Doe" Then
If Item.Attachments.Count > 0 Then
'loop through all attachments
For i = 1 To Item.Attachments.Count
mySaveName = Item.Attachments.Item(i).FileName
myExt = Split(mySaveName, ".")(1)
'Only save files with named extensions
Select Case myExt
Case "xls", "xlsm", "xlsx"
mySaveName = strFolder & "\" & mySaveName
Item.Attachments.Item(i).SaveAsFile mySaveName
Case Else
'do nothing
End Select
Next
Item.Delete
End If
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
MailItem does not expose a property named Recipient (singular). It exposes a property named Recipients (plural), but is is not a string property - it is a collection of Recipient objects, which expose Name and Address properties among others.
Did you mean to use the SenderName property instead?
I made a code that would take an incomming email in a specific folder (First a rule is created in order to move the mail to the folder and then the script is launched).
The problem is that the rule is working (it moves the mail to the folder), but the script isn't.
The thing is that when I take the new mail and transfer it to myself (My email is also in the receivers in the rules), the script is correctly working.
Here is the beginning of the code that I believe may be wrong.
Sub Script(item As Outlook.MailItem)
Dim strMailID As String
Dim objMail As Outlook.MailItem
Dim objNamespace As Outlook.NameSpace
strMailID = item.EntryID
Set objNamespace = Application.GetNamespace("MAPI")
Set objMail = objNamespace.GetItemFromID(strMailID)
Dim objpf As MAPIFolder
If objMail.MessageClass = "IPM.Note" Then
Any help would be appreciated
You need add an event listener to the default local Inbox, it worked with Outlook 2016.
This code will add an event listener to the default local Inbox. Action will be placed upon incoming emails. You need to add actions you need in the code below:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Goto ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' ******************
' do something here
' ******************
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
After pasting the code in ThisOutlookSession module, you must restart Outlook.
I would like to make it so if an email comes in with a phone number in the subject line (so 10 numerical digits) then the system automatically moves it to a folder called "Texting."
User Reidacus asked a very similar question here:
Move incoming mail to folders with RegEx in a rule
But I can't get it to work for me. When the email comes in it just sits in my inbox. I am very new the VBA and (sorry), I don't have a clue what I'm doing. Do I need to install anything special into my system to get this to work?
Here is my adapted code (note: in the real code I have my real email address)
Sub filter(Item As Outlook.MailItem)
Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Set ns = Application.GetNamespace("MAPI")
Set Reg1 = CreateObject("VBScript.RegExp")
Reg1.Global = True
Reg1.Pattern = "([\d][\d][\d][\d][\d][\d][\d][\d][\d][\d])"
If Reg1.Test(Item.Subject) Then
Set MailDest = ns.Folders("firstname.lastname#email.ca").Folders("Inbox").Folders("Texting")
Item.Move MailDest
End If
End Sub
In order for your Sub Filter to run everytime a new emails comes in, you need to add an "event listener", by adding the code below to the ThisOutlookSession module (this code is taken from home, here on SO : How do I trigger a macro to run after a new mail is received in Outlook? )
In order for this code to take affect, you must Restart Outlook.
ThisOutlookSession Module Code
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' get default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' Call your custom-made Filter Sub
Call filterNewMail_TenDig(item)
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Now, you only need to make the following modifications to your Module code. Using ns.GetDefaultFolder(olFolderInbox) will get you the default "Inbox" folder for the current profile (read here at MSDN link ).
Sub filterNewMail_TenDig Code
Sub filterNewMail_TenDig(item As Outlook.MailItem)
Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Set ns = Outlook.Application.GetNamespace("MAPI")
Set reg1 = CreateObject("VBScript.RegExp")
With reg1
.Global = True
.IgnoreCase = True
.Pattern = "\d{10,10}" ' Match any set of 10 digits
End With
If reg1.Test(item.Subject) Then
Set MailDest = ns.GetDefaultFolder(olFolderInbox).Folders("Texting")
item.Move MailDest
End If
End Sub
I want to write a VBA script that when Outlook receive a new email from a specific email address , the VBA script has to detect that and resend the new received email to all contacts in the address book .
For now i was able to send an email to all contacts in address book :
Sub SendEmails()
Dim ContactsFolder As Folder
Set ContactsFolder = Session.GetDefaultFolder(olFolderContacts)
Dim Contact As Object
Dim olApp As Outlook.Application
Dim objMail As Outlook.MailItem
Set olApp = Outlook.Application
For Each Contact In ContactsFolder.Items
Set objMail = olApp.CreateItem(olMailItem)
With objMail
.Subject = "Subject of the received email"
.Body = "Body of the received email"
.To = Contact.Email1Address
.Send
End With
Next
End Sub
but how to use this script so it called when a new email received from a specific email address.
i tried to put this in ThisOulookSeassion to check for new message event so i could call my above code within it :
Private Sub Application_NewMail()
MsgBox "New mail"
End Sub
but it didn't work.
Also i tried this (i put it in ThisOulookSeassion too) :
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Goto ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
' ******************
' and placing my code here.
' ******************
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
but when i click run it ask me to create new macro and don't run the code.
Any suggestions ?
The simplest way is to create a rule in Outlook. Then you can assign an existing VBA macro to run when the rule is run. Typically a VBA sub should like the following one:
Sub SendEmails(mail as MailItem)
Dim ContactsFolder As Folder
Set ContactsFolder = Session.GetDefaultFolder(olFolderContacts)
Dim objMail as MailItem
Dim Contact As Object
For Each Contact In ContactsFolder.Items
Set objMail = olApp.CreateItem(olMailItem)
With objMail
.Subject = mail.Subject
.Body = "Body Text"
.To = Contact.Email1Address
.Send
End With
Next
End Sub
Also you may consider adding recipients to the Recipients collection and set their Type to the olBCC value. Thus, each of them will recieve a separate email and you have to submit only a single mail item.