Trigger to run a outlook macro - vba

is there a way Outlook automatically runs a macro whenever I get an email that goes to a specific folder in Outlook (just to clarify, the email goes there because I have set up a rule, so instead of going to my inbox it goes to that folder).
I think I would need code that detects whenever my folder receives an new email and then automatically runs the macro.
My code is the following, I execute test, which executes SaveEmailAttachmentsToFolder.
Sub Test()
'Arg 1 = Folder name of folder inside your Inbox 'Arg 2 = File extension, "" is every file 'Arg 3 = Save folder, "C:\Users\Ron\test" or "" ' If you use "" it will create a date/time stamped folder for you in your "Documents" folder ' Note: If you use this "C:\Users\Ron\test" the folder must exist.
SaveEmailAttachmentsToFolder "Dependencia Financiera", "xls", "V:\Dependencia Financiera\Dependencia Financiera\"
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _ ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As Folder
Dim SubFolder As Folder
Dim subFolderItems As Items
Dim Atmt As Attachment
Dim FileName As String
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
Set subFolderItems = SubFolder.Items
If subFolderItems.Count > 0 Then
subFolderItems.Sort "[ReceivedTime]", True
For Each Atmt In subFolderItems(1).Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Next Atmt
End If
' Clear memory ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set subFolderItems = Nothing
End Sub
seulberg1 told me to use the follwing code how, should my paste my own code since, it has 2 Subs.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup() Dim olApp As Outlook.Application
Set olApp = Outlook.Application Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Folders("YourFolderName").Items End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Add your code here
ProgramExit: Exit Sub ErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ProgramExit End Sub
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace Set GetNS = app.GetNamespace("MAPI") End Function
Thanks you in advance !!!

This code (adapted from Jimmy Pena) should do the trick.
It initiates the event listener on Outlook startup and checks the folder "Your Folder Name" for new emails. It then performs a designatable action at the ("Add your code here") section.
Let me know if this helps
Best regards
seulberg1
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Folders("YourFolderName").Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
**'Add your code here**
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function

Related

Run code when new email comes to any subfolder in a Shared Mailbox

I want to run code when any new email comes to a specific shared mailbox.
The event triggers when the email comes to INBOX folder.
The event does not trigger if a new email comes straight to its subfolders - like to shared#mailbox.com/Inbox/subfolder1.
What should I change so the code runs if a new email comes to any subfolder in the inbox?
The mailbox has a lot of subfolders. Moreover their structure may change.
Option Explicit
Private WithEvents mtFolder As Outlook.Folder
Private WithEvents mtItems As Outlook.Items
Private Sub mtItems_ItemAdd(ByVal Item As Object)
Debug.Print "XXX"
'my CODE
End Sub
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Dim objOwner
Set objOwner = Ns.CreateRecipient("shared#mailbox.com")
objOwner.Resolve
If objOwner.Resolved Then
Set mtFolder = Ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set mtItems = mtFolder.Items
End If
Set Ns = Nothing
Exit Sub
eh:
End Sub
Thank you a lot for your help! Here the solution.
At first I have added Class Module named "clsFolder" with events:
Option Explicit
Private OlFldr As Folder
Public WithEvents Items As Outlook.Items
'called to set up the object
Public Sub Init(f As Folder) ', sPath As String)
Set OlFldr = f
Set Items = f.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Debug.Print "eMail '" & Item.Subject & "' was added to Folder '" & OlFldr.name & _
"'. Mailbox: '" & Item.Parent.Store & "'."
'do sth with a email added...
End If
End Sub
Then in ThisOutlookSession I setup a collecion of folder for all (sub)folders in the SharedMailbox:
Option Explicit
Public colFolders As Collection '<< holds the clsFolder objects with events
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim oFolder As Outlook.Folder
Set Ns = Application.GetNamespace("MAPI")
Dim objOwner
Set objOwner = Ns.CreateRecipient("my_Shared_Mailibox")
objOwner.Resolve
If objOwner.Resolved Then
Set oFolder = Ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set colFolders = New Collection
processFolder oFolder
End If
Set Ns = Nothing
Set oFolder = Nothing
Exit Sub
eh:
End Sub
'function to create folder objects
Function GetFolderObject(foldr As Folder)
Dim rv As New clsFolder
rv.Init foldr
Set GetFolderObject = rv
End Function
'process all subfolders
Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
colFolders.Add GetFolderObject(oParent)
Dim oMail As Outlook.MailItem
For Each oMail In oParent.Items
'do sth with every email if necessary
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub

Error 438 When Saving Attachments using Outlook VBA

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?

How to Automatically Move an Email to a Folder if it Contains 10 digits in the subject line

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

Forward email based on subject line

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

Outlook - Save file from email with .xls attachment and from specific sender then move email to sub folder

I want to trigger a macro when a new email from a specific email address with an .xls attachment is received in an inbox.
I have tried to set a rule in outlook but it doesn't filter on the sender nor if it has an attachment.
What I would like to do is the following:
When a new email comes into the inbox check if it is from a certain email address ag:Myaddress.me.co.uk. If the email is not from the correct address do nothing.
If the subject line has certain words eg: " Price Checks". It the subject doesn't match do nothing.
If the email is from the correct address Check the new email has a .xls attachment. If it doesn't have the .xls attachment do nothing.
Save the attachment in a folder eg:"C:\MyFolder"
Mark the Email as Read and move to a sub folder eg: "PriceCheckFolder"
I have been using this code to check the inbox but it looks through all emails in the folder and I only want it to look at the first instance that fits the criteria.
Many Thanks Melinda
‘in thisworkbook
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim SubFolder As MAPIFolder
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
Call SaveAttachmentsToFolder
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Sub SaveAttachmentsToFolder()
'Error handling
On Error GoTo SaveAttachmentsToFolder_err
‘in module1
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Dim StringLength As Long
Dim Filename1 As String
Dim FilenameA As String
Dim FilenameB As String
'Set the variable values to be used in the code
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Test")
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
' "Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each item In SubFolder.Items
For Each Atmt In item.Attachments
' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
StringLength = Len(Atmt.FileName)
FileName = "\\feltfps0003\gengrpshare0011\Value Team\Melinda_BK\OutlookVBA\TestOutput\" & Left(Atmt.FileName, (StringLength - 13)) & Format(item.CreationTime, "ddmmmyyyy") & ".xls"
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next item
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"sub
Resume SaveAttachmentsToFolder_exit
End Sub
I have tried to set a rule in outlook but it doesn't filter on the sender nor if it has an attachment.
Create a rule calling the following script.
It will run on all incoming mail but only execute your code for whatever email address you look for
Sub checkEmailSenderAndDoStuff(myItem As MailItem)
'set this up as a script to run on all incoming mail
Dim myTargetEmailAddress As String
myTargetEmailAddress = "whatever#wherever.com"
'this will check if the sender email is whatever sender
'you want to check from
If myItem.SenderEmailAddress = myTargetEmailAddress Then
'do whatever you wanted to do with attachments, moving, etc
End If
End Sub