I am trying to run a function every time a new mail arrives in outlook. I have been doing some searching but I am unable to find I way to fire code every time an email arrives. Is there a new mail event that I could utilize?
I added a simple MsgBox to it to be able to see if the event is firing but it did not seem to be working. I placed this code in the ThisOutlookSession module. Any adivice? Here is my code.
Public WithEvents myOlApp As Outlook.Application
Sub Initialize_handler()
Set myOlApp = CreateObject("Outlook.Application")
End Sub
Private Sub myOlApp_NewMail()
Dim myExplorers As Outlook.Explorers
Dim myFolder As Outlook.MAPIFolder
Dim x As Integer
Set myExplorers = myOlApp.Explorers
Set myFolder = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
If myExplorers.Count <> 0 Then
For x = 1 To myExplorers.Count
On Error GoTo skipif
If myExplorers.Item(x).CurrentFolder.Name = "Inbox" Then
MsgBox ("Test")
myExplorers.Item(x).Display
myExplorers.Item(x).Activate
Exit Sub
End If
skipif:
Next x
End If
On Error GoTo 0
myFolder.Display
End Sub
Try to put:
Private Sub Application_NewMail()
MsgBox "New mail"
End Sub
In "ThisOutlookSession"
There's a good example on MSDN showing how to display the inbox when a new mail arrives (using Outlook.Explorers). You can probably adapt it pretty readily for your own program.
Related
I would like to move emails to a sub-folder of my inbox when I assign it a category
I found the following code from Extended Office but it does not work.
It is supposed to move mail to a subfolder with the same name as the category and create a folder if it does not exist.
I have enabled macros in Outlook's security settings and inserted some message box alerts to confirm that does in fact run.
The code is in ThisOutlookSession
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
MsgBox "Macros are working"
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
MsgBox "Item Changed"
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
xMailItem.Move xTargetFld
End If
End If
End Sub
I don't know exactly why but this suddenly started working today, I had restarted Outlook several times before but after I needed to force close Outlook this morning it started working.
(I'm not even sure if it started working immediately because of the restart or if it was a short time afterwards triggered by something else)
I'm trying to finalize an integration between my access system and Outlook.
The basis of the system is that Outlook needs to trigger a script when an email enters a specific Inbox. This script then opens the Access DB and runs it's own function to go through that inbox, take the attachment in the email and import it into the database.
Currently both scripts "Work" in so far as Outlook calling Access and Access doing it's thing. The problem is when Outlook executes the script, it's BEFORE the message is actually in the mailbox. The access app will launch, scan the inbox as empty and close just before the message actually enters the inbox.
I've tried adding a "Pause" loop in the script, to try and have it wait until the email is readable before opening the access app, but that just froze outlook for the duration of the "Pause" instead of letting the email become readable.
Here is my script in Outlook:
Sub ExecuteDealRequest(item As Outlook.MailItem)
Dim currenttime As Date
currenttime = Now
Do Until currenttime + TimeValue("00:00:30") <= Now
Loop
Dim AccessApp As Access.Application
Set AccessApp = CreateObject("Access.Application")
AccessApp.OpenCurrentDatabase ("C:\commHU\Comm HU Request.accdb"), False
AccessApp.Visible = True
AccessApp.DoCmd.RunMacro "Macro1"
Set AccessApp = Nothing
End Sub
At this point: I'm using outlook rules to launch the script:
Apply this rule after the message arrives
With Pricing Request in the Subject
and on this computer only
Move it to the Pricing Requests folder
and run Project.ExecuteDealRequest
and stop processing more rules
Any help would be great, as this is the last piece that I need to get working
You don't need Rule, Try it this way- code in ThisOutlookSession
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf item Is Outlook.MailItem Then
ExecuteDealRequest Item
End If
End Sub
' ---- Your Code
Sub ExecuteDealRequest(Item As Outlook.MailItem)
Dim currenttime As Date
Dim AccessApp As Access.Application
Set AccessApp = CreateObject("Access.Application")
AccessApp.OpenCurrentDatabase ("C:\commHU\Comm HU Request.accdb"), False
AccessApp.Visible = True
AccessApp.DoCmd.RunMacro "Macro1"
Set AccessApp = Nothing
End Sub
You could try something like this,
Add this code to wait for a new email
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
ThisOutlookSession.GetNamespace("MAPI").GetItemFromID(EntryIDCollection).Subject
' Check for the email subject / any property
'then call your method
End Sub
I have a userform that is prompted when I send emails (works great. not the problem) and from there when I click the buttons on the form it moves that email to the respective folder.
What I now want is for that same userform (rather, a duplicate) to be prompted when a message in my inbox goes from unread to read. The buttons on the userform would then move that message to the respective folder.
Code to bring up userform when sending emails:
Private Sub Application_ItemSend(ByVal Item As Object, cancel As Boolean)
UserForm1.Show vbModal
cancel = False
End Sub
Code snippet for a button of the userform:
Private Sub CommandButton1_Click()
On Error GoTo error_movemessage
Dim myolapp As New Outlook.Application
Dim mynamespace As Outlook.NameSpace
Dim myinbox As Outlook.MAPIFolder
Dim mydestfolder As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myItem As Object
Set mynamespace = myolapp.GetNamespace("MAPI")
Set myinbox = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("RetainPermanently")
Set myitems = myinbox.Items
Set mydestfolder = myinbox
Set myItem = Application.ActiveInspector.CurrentItem
myItem.Move mydestfolder
Unload Me
exit_CommandButton1_Click:
Exit Sub
error_movemessage:
MsgBox "ERROR! " & Err.Description
Resume exit_CommandButton1_Click
End Sub
I searched far and wide for pieces to this puzzle and ultimately ended up unsuccessful. Thank you in advance!
Update:
Private Sub getselecteditem_click()
Dim oApp As New Outlook.Application
Dim oExp As Outlook.Explorer
Dim oSel As Outlook.Selection
Dim oItem As Object
Set oExp = oApp.Application
Set oSel = oExp.Selection
For i = 1 To oSel.Count
Set oItem = oSel.Item(i)
If oItem.Class = olMail Then
End If
Next i
End Sub
Sub oItem_PropertyChange(ByVal Name As String)
Select Case Name
Case "UnRead"
If oItem.UnRead = False Then
UserForm2.Show vbModal
End If
End Select
End Sub
Still doesn't work however.
I realized that I've been making this much harder than it needs to be. I can simply get it to pull up the prompt whenever i load a mailitem that happens to be unread. Here is an update:
Private Sub Application_ItemLoad(ByVal Item As Object)
If Item.Class = olMail Then
If Item.UnRead Then
UserForm2.Show vbModal
End If
End If
End Sub
Firstly, if you move an item to a different folder when the message is sent, you are asking for trouble - if you want the message to be saved in a folder other than Sent Items, set the MailItem.SaveSentMessageFolder property.
To move a message when its read state changes, track the Explorer.SelectionChange event. When SelectionChange event fires, start tracking the events on multiple messages from the Explorer.Selection collection (there can be more than one, but you can get away with just the first one as a proof of concept). When MailItem.PropertyChange event fires on the Unread property, display your prompt and move the message.
I am trying to write a brief VBA script that will move incoming messages from my Outlook Inbox to a subfolder. This is what I currently have (assembled from various posts), but I'm not getting any result when I send test emails. If there are any other posts that would relate to this, I would appreciate it!
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
Set myInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
If TypeName(item) = "MailItem" Then
Set Msg = item
If Msg.SenderEmailAddress = "name#example.com" Then
If InStr(0, Msg.Subject, "Subject Title", vbTextCompare) > 0 Then
Msg.Move myInbox.Folders("Test").Subfolder("Destination")
End If
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
It looks like you didn't define and initialize the Items object properly. For example:
Public WithEvents myOlItems As Outlook.Items
Public Sub Initialize_handler()
Set myOlItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Items
End Sub
Private Sub myOlItems_ItemAdd(ByVal Item As Object)
' do something here
End Sub
Be aware, the ItemAdd event is not fired when more than 16 items is added at the same time. This is a known issue in the OOM.
Try to use the NewMailEx event of the Application class instead. And I'd suggest reading the following series of articles:
Outlook NewMail event unleashed: the challenge (NewMail, NewMailEx, ItemAdd)
Outlook NewMail event: solution options
Outlook NewMail event and Extended MAPI: C# example
Outlook NewMail unleashed: writing a working solution (C# example)
Finally, is your macro enabled in Outlook? Have you checked out the Trust center settings?
Put your code in ThisOutlookSession.
Just above your code put
Public WithEvents Items As Items
When using the built-in class module ThisOutlookSession, Sub Application_Startup() initializes the handler.
I have a macro to export relevant field of emails in a subfolder but I need it to automatically run every time I receive a new email. In fact I only want the subject line exported, is there a script which will trigger that macro ('ExportMessagesToExcel') when an email lands in 'M_M_Asia'?
I'm in Outlook 2007.
I'll be forever grateful if anyone can help. Cheers guys.
You should be able to use the Application_NewMail (or NewMailEx) event in ThisOutlookSession module to call your own macro.
Another way is to create a rule that runs a VBA-script, but then you VBA sub needs to handle a MailItem parameter:
Option Explicit
Sub MyVBARule(poMail As MailItem)
End Sub
Or you could add 'ItemAdd' event handler, example here:
Option Explicit
Private Const ASIA_FOLDER_NAME As String = "M_M_Asia"
Private WithEvents m_outlookFolderItems As Outlook.Items
Private Sub Application_Startup()
Initialize_Handler
End Sub
Private Sub m_outlookFolderItems_ItemAdd(ByVal Item As Object)
' You have new mail in folder ASIA_FOLDER_NAME
RunExcelMacro
End Sub
Private Sub Initialize_Handler()
Dim outlookFolder As Outlook.MAPIFolder
Dim defaultInboxFolder As Outlook.MAPIFolder
Dim outlookNameSpace As Outlook.NameSpace
Set outlookNameSpace = Outlook.GetNamespace("MAPI")
Set defaultInboxFolder = outlookNameSpace.GetDefaultFolder(olFolderInbox)
Set outlookFolder = defaultInboxFolder.Folders(ASIA_FOLDER_NAME)
Set m_outlookFolderItems = outlookFolder.Items
End Sub
Public Sub RunExcelMacro()
On Error GoTo RunExcelMacro_Err
Const path As String = "C:\temp\Excel_VBA\"
Const fileName As String = "CallMeFromOutloouk.xlsm"
Const macroName As String = "CallMeFromOutlook"
Dim excelObject As Object
Dim workbookObject As Object
Set excelObject = CreateObject("Excel.Application")
On Error Resume Next
Set workbookObject = excelObject.Workbooks(fileName)
On Error GoTo RunExcelMacro_Err
If workbookObject Is Nothing Then
Set workbookObject = excelObject.Workbooks.Open(path & fileName)
End If
excelObject.Run fileName & "!" & macroName
Exit Sub
RunExcelMacro_Err:
MsgBox Err.Description
End Sub