Rerun Outlook VBA script 'Application_Startup' regularly - vba

I have (using information from SO) implemented a VBA macro that runs to process new emails after the 'run a script' options was removed from the Outlook rules. I do this as follows:
Private WithEvents Items As Outlook.Items
Public Sub Application_Startup()
' Add an inbox event listener
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
MsgBox "Startup macro run"
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
'Do something on new email arrival
.
.
.
End Sub
However the inbox listener appears to frequently stop working and I either have to restart Outlook or re-run the 'Startup' macro manually to kick it back into life - this appears to be a common problem with no solution.
Question - I'm not a VBA expert and I was wondering if I can I simply re-run the 'Application_Startup' macro to restart the listener at the end of the 'Items_ItemAdd(ByVal item As Object)' macro?

If you need to reset the ItemAdd event handler, I don't think using ItemAdd to do that makes any sense.
You can either use a timer (which does not exist in VBA) or you can use some other event that fires more or less frequently, such as the Explorer.SelectionChange event (Explorer can be retrieved from Application.ActiveExplorer).

You could add a new macro that does the actions originally present in the Application_Startup event. Then you could later refer to that sub at the end of your Items_ItemAdd macro.
Private WithEvents Items As Outlook.Items
Public Sub Application_Startup()
Call startupevents
End Sub
Sub startupevents()
' Add an inbox event listener
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
MsgBox "Startup macro run"
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
'Do something on new email arrival
'
'
'
Call startupevents
End Sub

Simpler code may have an impact.
Private WithEvents Items As Outlook.Items
Public Sub Application_Startup()
' Add an inbox event listener
Dim objNS As Outlook.NameSpace
' The code is in Outlook, not being called, for example, from Excel.
Set objNS = Session.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
MsgBox "Startup macro run"
End Sub
If the above has no impact then this may rerun Application_Startup frequently enough.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Application_Startup
End Sub

Related

Automatically Mark email in Deleted Items as Read Outlook 2016 VBA

I had a little macro set up with Outlook on another machine but now that I've switched computers I can't get it to work. When I try to run the last Private Sub, it doesn't recognize the name and pulls up the Macro selection box with no options listed.
I dislike having to manually mark emails in the Deleted Items folder as read, especially considering they had the amazing foresight to mark discarded drafts as unread.
Here's the code that used to work:
Dim WithEvents g_OlkFolder As Outlook.Items
Private Sub Application_Quit()
Set g_OlkFolder = Nothing
End Sub
Private Sub Application_Startup()
Set g_OlkFolder = Session.GetDefaultFolder(olFolderDeletedItems).Items
End Sub
Private Sub g_OlkFolder_ItemAdd(ByVal Item As Object)
Item.UnRead = False
Item.Save
End Sub
Here are a few things to try and check:
Put the cursor in the Application_Startup method and press F5. Then go back and try again. If this helps, the initialization has not run, and the g_OlkFolder variable is not set.
Put a breakpoint on the Item.UnRead = False line. If it doesn't stop there, your method isn't running.
Have you put your code in the ThisOutLookSession module?
Try using Application.Session property, or use GetNamespace method which I prefer
Example
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Set Items = DeletedFolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
' do something with Item
End If
End Sub
Or define olFolderDeletedItems or replace it with 3.
See this link for details.
Upon completely throwing away my code and starting from scratch I figured out a much simpler solution than what I was trying. Thanks for all the help anyways guys!
Sub MDAU()
Dim DI As Outlook.Items
Dim MSG As Object
Set DI = Session.GetDefaultFolder(olFolderDeletedItems).Items
Set MSG = Application.CreateItem(olMailItem)
For Each MSG In DI
MSG.UnRead = False
Next
End Sub

Outlook run macro when mail arrives on a nondefault mailbox

I have multiple mailboxes set-up in my Outlook 2010. I would like a macro to run when I receive a mail on one of the non-default mailboxes.
I have coded the below and inserted the code into "ThisOutlookSession".
I have gotten it to work for the default mailbox's inbox but not my nondefault mailbox's inbox. When I try to re-open outlook 2010 having inserted the code, It tells me :
"Compile error in hidden module: ThisOutlookSession". The non-default box is called 'abc.asia'.
I am new to vba so any inputs are appreciated, thank you!
Dim WithEvents myInboxMailItem As Outlook Items
Private Sub myInboxMailItem_ItemAdd(ByVal Item As Object)
MsgBox("Item Added")
End Sub
Private Sub Initialize_Handler()
Dim fldInbox As Outlook.MapiFolder
Dim gnspNameSpace As Outlook.NameSpace
Set gnspNameSpace = Outlook.GetNameSpace("Mapi")
Set fldInbox = gnspNameSpace.Folders("abc.asia").Folders("Inbox")
Set myInboxMailtItem = fldInbox.Items
End Sub
Update Set olRecip = olNs.CreateRecipient("emal#address.com") with correct Email address.
Option Explicit
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim olRecip As Recipient
Set olNs = Application.GetNamespace("MAPI")
Set olRecip = olNs.CreateRecipient("emal#address.com") '// Owner's Name or email address
Set Inbox = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Debug.Print Item.Subject
End If
End Sub

VBA Outlook userform prompt

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.

Moving Outlook message with specific subject to Subfolders

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.

While itemadd event works in my outlook it doesn't work in friends pc

I have code which works in my system but not in my friend's PC. Both use the same Outlook version.
Here is the snippet.
Private WithEvents olInboxItems As Items
Private Sub start_Click()
Dim objNS As nameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Call accessInbox(inbox) // my own function
Set olInboxItems = inbox.Items
'Set objNS = Nothing
Me.Hide
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
MsgBox "a Message recieved"
'Call download(Item)
Call multiSubjectDownload(Item) //my own function
End Sub
What may be the problem?
Are there settings that differ which prevent the code detecting new mail in inbox?
i found the error i was n't referring to inbox. so event was not firing because my item event was on inbox :)