I use a outlook rule to process incoming mail via a VBA macro.
in the vba various actions are triggerd to process attachments of the incoming mail.
The problem is, there somethimes is a stack of e-mails that need to be processed.
I cant seem to find a way how to trigger the one by one.
I want to wait a few seconds before processing the next mail, if there is a stack.
Putting a sleep method in the macro doesnt seem to have effect. the rule doesnt seem to wait for the previous message to be done.
My method i something like:
Is there a way to accomplish this behaviour?
Private Sub ProcessMail(ByVal Item As Object)
Dim objNS As Outlook.NameSpace
Set objNS = GetNamespace("MAPI")
If TypeOf Item Is Outlook.MailItem Then
Dim Msg As Outlook.MailItem
DoProcessingMethod
End If
End If
End Sub
Putting a wait or sleep in the method doesnt cause it to be processed one by one.
GD Arnold,
You could indeed use the ItemAdd option as per #Brett's answer.
I use a similar process to automatically upload received data (as attachment in an email) and upload this to a MySQL database. The action is triggered by the ItemAdd method and mails are checked one-by-one.
Simplified instructions:
Add a Class to your VBA code named "EventClassModule"
In your class, type
Public WithEvents dItems As Outlook.Items
In your ThisOutlookSession make a sub that registers the event_handler:
Sub Register_Event_Handler()
Set myClass.dItems = Outlook.Items
End Sub
In your ThisOutlookSession make a sub that handles the ItemAdd event as below:
Private Sub dItems_ItemAdd(ByVal newItem As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
If newItem.Class = olMail Then
Set msg = newItem
'Do something with the msg item, check rules, check subject, check whatever
'This will process messages when the arrive in your mailbox one by one.
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
These steps should provide you with a sub that is triggered when a new mail arrives.
You could then call a function/sub like below.
The below sub runs all rules based on an optional ruleSet variable, it checks the rule.Name against the ruleSet and if the ruleSet string exists in the rule.Name then it executes some code. This way you can have multiple rules and only execute some of them based on which 'ruleSet' they are part of. You can define that by altering their name.
It's a refinement of the 'Run Rules' option in Outlook.
Some of this code came frome here: Setting VBA to read personal inbox
Sub runRules(Optional ruleSet As String)
Dim olStore As Outlook.Store
Dim myRules As Outlook.Rules
Dim tmpInbox As Outlook.Folder
Dim tmpSent As Outlook.Folder
Dim rl As Outlook.Rule
'On Error Resume Next
'toTmpBox (ruleSet)
' get default store (where rules live)
Set olStore = Application.Session.DefaultStore
With olStore
Set tmpInbox = .GetDefaultFolder(olFolderInbox) '.Folders("tmpInbox")
Set tmpSent = .GetDefaultFolder(olFolderSentMail) '.Folders("tmpSentBox")
End With
' get rules
Set myRules = olStore.GetRules
' iterate through all the rules
For Each rl In myRules
Debug.Print rl.Conditions.Body.Enabled & " " & rl.Conditions.Body.Text
If InStr(LCase(rl.Name), ruleSet) > 0 And (rl.Enabled) Then
rl.Execute ShowProgress:=True, Folder:=tmpInbox
If ruleSet = "autorun" Then
rl.Execute ShowProgress:=True, Folder:=olStore.GetDefaultFolder(olFolderSentMail)
End If
ruleList = ruleList & vbCrLf & rl.Name
End If
Next
' tell the user what you did
ruleList = "These rules were executed " & _
vbCrLf & ruleList
MsgBox ruleList, vbInformation, "Macro: RunMyRules"
CleanUp:
Set olStore = Nothing
Set tmpInbox = Nothing
Set tmpSent = Nothing
Set rl = Nothing
Set myRules = Nothing
End Sub
I have come across a similar problem. In my case my tool would run at regular time interval and each time I had to capture new emails only. Now new emails could be one or multiple. the solution I found was as given below.
Each time the tool would run. it will capture the new emails and just mark a simple ',' or '|' anything of your choice at the end of the subject in such a way that no one will notice. Now next time when the tool runs it checks if the emails received for the entire day or two (based on your requirements) has those markers or not.
This solution works if the email communication is one way. If we use these email for chain emails then their is another solution.
Here you will have to save the time max time of emails captured in the last run. Now each time you run you just have to run it for the entire day and put an if statement that is should be greater then time last captured.
Now to store the max time you might need to create a folder and an email. The email can help you to store the each time the run happens
item.subject = maxtime
item.save
Related
I have been tasked to create an automated report system where an report from Google Data Studios are uploaded to specific projects (On a site called Basecamp). The reports always include both a report within the body of the e-mail and an attached PDF file. The are sent to a Gmail account (data studios refuse to schedule towards a non-Google account). The filters within Gmail doesnt really work well with the Basecamp system so I use filters to re-route them towards a Outlook account. There I use rules to send each e-mail towards the correct client within Basecamp.
Here comes the problem, Basecamp shows both the body of the e-mail AND the attached PDF version which makes us show duplicates.
Is there a way to create a macro that first deletes all attachments (or body of an e-mail) and THEN forward the e-mail.
It cant be done manually it have to be a rule that does it automaticaly. Keep in mind that I am not a coder and have never done anything like this so please keep it simple for my dumb brain!
Thank you in advance!
Marcus
PS: I found a code that seems to be what I am after.
Public WithEvents ReceivedItems As Outlook.Items
Private Sub Application_Startup()
Set ReceivedItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub ReceivedItems_ItemAdd(ByVal Item As Object)
Dim xForwardMail As Outlook.MailItem
Dim xEmail As MailItem
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xEmail = Item
If InStrRev(UCase(xEmail.Subject), UCase("kto feature")) = 0 Then Exit Sub 'change subject text to your need
If xEmail.Attachments.Count = 0 Then Exit Sub
Set xForwardMail = xEmail.Forward
With xForwardMail
.HTMLBody = ""
With .Recipients
.Add "skyyang#addin88.com" 'change address to your own
.ResolveAll
End With
.Send
End With
End Sub
I am trying to get that code to work, and changes the subject to a specific word and then route it to a final e-mail account that then filters out to correct clients. However the code doesnt seem to work, it DOES forward the e-mail but the attachment is still there. The code was found at https://www.extendoffice.com/documents/outlook/5359-outlook-forward-attachment-only.html#a1
It seems you need to modify the code slightly:
Public WithEvents ReceivedItems As Outlook.Items
Private Sub Application_Startup()
Set ReceivedItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub ReceivedItems_ItemAdd(ByVal Item As Object)
Dim xForwardMail As Outlook.MailItem
Dim xEmail As MailItem
Dim myattachments as Outlook.Attachments
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Set xEmail = Item
If InStrRev(UCase(xEmail.Subject), UCase("kto feature")) = 0 Then Exit Sub 'change subject text to your need
If xEmail.Attachments.Count = 0 Then Exit Sub
Set xForwardMail = xEmail.Forward
Set myattachments = xForwardMail.Attachments
While myattachments.Count > 0
myattachments.Remove 1
Wend
With xForwardMail
.HTMLBody = ""
With .Recipients
.Add "skyyang#addin88.com" 'change address to your own
.ResolveAll
End With
.Send
End With
End Sub
The Remove method of the Attachments class removes an object from the collection.
I'm trying to use Outlook VBA to check all my emails on startup, and whenever I receive a new email, to see if the email subject is "Sample Daily Data Pull". If the email subject matches, I want outlook to save the attachment to a specified network drive folder. Here is the code I have:
In "ThisOutlookSession"
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)
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
If Item.Subject = "Sample Daily Data Pull" Then
Call SaveAttachmentsToDisk
Else
End If
End If
End Sub
I also have the following code in a module:
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "N:\SampleFilePath\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub
This is my first time working in Outlook VBA, so my apologies if it's something very basic and obvious. Not really sure what is going wrong as I'm not getting any error messages. All I know is that the the macro is not saving attachments on my network drive as it should be.
Thanks in advance for any help.
Your code does not work for me because of:
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
Outlook saves mail items, calendar items, tasks and other such information in files it calls Stores. You can have several stores each of which will have an Inbox. I am a home user with two email accounts. I did a default installation of Outlook then used a wizard to add an account for each of my email addresses. The result is I had three stores:
Outlook Data File
MyName#myisp.com
MyName#gmail.com
“Outlook Data File” is the default store and contains the default Inbox but new emails are placed in the Inboxes in the other two stores. To test if you have the same problem, open Outlook, open the VBA Editor, type the following into your Immediate Window and press [Return].
? Session.GetDefaultFolder(olFolderInbox).Parent.Name
On my system, this statement outputs “Outlook Data File” because that store contains the default Inbox. If I want to have an event handler for new emails I need to have:
Private Sub Application_Startup()
Set InboxItems = Session.Folders("MyName#myisp.com").Folders("Inbox").Items
End Sub
This is someone shorter than your macro, which I will explain later, but the key difference is I am naming the Inbox I wish to monitor. If the Inbox that receives your new emails is not Outlook’s default Inbox, you will have to name the folder containing the Inbox you wish to monitor.
Why is my macro so much shorter than yours?
Dim outlookApp As Outlook.Application
Set outlookApp = Outlook.Application
You are already within Outlook so these statements are redundant.
You could replace:
Set objectNS = outlookApp.GetNamespace("MAPI")
by
Set objectNS = Application.GetNamespace("MAPI")
But you do not have to. The only GetNamespace is under Application so the qualification is optional. The only qualification that I know to be non-optional is Outlook.Folder and Scripting.Folder. If you write Folder within Outlook it assumes you want one of its folders. If you want to refer to a disk folder you must say so.
You have:
Dim objectNS As Outlook.NameSpace
Set objectNS = outlookApp.GetNamespace("MAPI")
I have used Session. The documentation states that Namespace and Session are identical. I prefer Session but most people seem to prefer Namespace. Your choice.
If you are references the correct Inbox, we need to look further for the cause of your problem.
The next possible issue is If Item.Subject = "Sample Daily Data Pull". This requires Item.Subject be exactly equal to "Sample Daily Data Pull". An extra space or a lower case letter and they are not equal.
Next, I suggest adding a statement at the top of each of procedure to give:
Private Sub Application_Startup()
Debug.Assert False
: : :
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
Debug.Assert False
: : :
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Debug.Assert False
: : :
Many programming languages have an Assertion statement; this is VBA’s version. It allows the programmer to assert that something will be true. Execution will stop if the assertion is false. I find Debug.Assert False invaluable during testing. Debug.Assert False will always be false so execution will always stop. This is an easy way to test that Application_Startup, inboxItems_ItemAdd and SaveAttachmentsToDisk are being executed.
Try the above suggestions. If they fail to find a problem, we will have to try something else.
Error Handling
In your original posting, you had:
On Error GoTo ErrorHandler
: : :
: : :
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
You will often see code like this but I have never seen a justification for it.
If an error occurs during development, this code will result in the error number and description being displayed and the routine exited. How is this helpful? It leaves you to guess from the error description which statement failed. If you omit all the error code, execution stops on the faulty statement. There is no guessing as to which statement was in error. If you can fix the error, you can click F5 and restart with the previously faulty statement. Even if you cannot fix and restart, you have a better understanding of the situation.
For a live system, I have difficulty in imagining anything less user friendly than an error resulting in display of a cryptic error message and the macro terminating.
For a live system, you want something like:
Dim ErrNum As Long
Dim ErrDesc As String
On Error Resume Next
Statement that might fail
ErrNum = Err.Num
ErrDesc = Err.Description
On Error GoTo 0
If ErrNum > 0 Then
' For each possible value for ErrNum, code to provide user friendly
' description of what has gone wrong and how to fix it.
End If
VBA is not the ideal language for writing code that fails gracefully but with care you can create some very acceptable error handling code.
I need to create custom filters in Outlook to save me from having to manually adjust the filter setting each time, preferably with VBA.
Below is my attempt. I inserted the message box line to check the correct items are being restricted. On running the macro I get a number of message boxes displayed with "1" indicating to me that it is working as expected (message box appears for each 'In Progress' item).
For Each Task_List In CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(13).Items.Restrict("[Status]='In Progress'")
MsgBox Task_List.Status
sFilter = "[Status]=Task_List.Status"
Next
However, the tasks in the task folder are not filtered, all the tasks are displayed regardless of criteria.
What am I missing from my code? Or am I completely barking up the wrong tree.
Thanks, and apologies in advance for the simplistic question.
Once you manually set up different views you can get to them this way.
Where the view is named for instance "In Progress"
Sub TaskView_InProgress()
' No error if the view does not exist
' No error if not currently in Tasks folder
ActiveExplorer.CurrentView = "In Progress"
End Sub
This demonstrates how to access the In Progress tasks. Albeit much less helpful than a view if you have many tasks.
Private Sub task_Filter()
' Folders may contain any type of item
Dim myItem As Object
Dim myItems As items
Dim resItems As items
Dim myTaskFolder As Folder
Dim sFilter As String
Dim msgPrompt As String
Set myTaskFolder = Session.GetDefaultFolder(olFolderTasks)
Set myItems = myTaskFolder.items
sFilter = "[Status]='In Progress'"
Set resItems = myItems.Restrict(sFilter)
For Each myItem In resItems
If myItem.Class = OlTask Then
myItem.Display
End If
Next
End Sub
This sub worked great for my purpose. I wanted to also input a string in the search field of the task window from excel. So I loaded the string to the clipboard and used send keys to "Ctrl E" (enter search field) then "Ctrl V" paste. This routine turns num lock off. So I added a toggle for that.
Sub btn_GotoTask()
Set cl = New clsClient
' Folders may contain any type of item
Dim myItem As Object
Dim myItems As items
Dim resItems As items
Dim myTaskFolder As Folder
Dim sFilter As String
Dim msgPrompt As String
On Error GoTo outlookError
Set myTaskFolder = Session.GetDefaultFolder(olFolderTasks)
myTaskFolder.Display
SetClipboard cl.Pol
'Activate task window
myTaskFolder.Application.ActiveWindow
SendKeys "^{e}"
SendKeys "^{v}"
SendKeys "{NUMLOCK}"
Exit Sub
outlookError:
MsgBox "Outlook may not be open"
End Sub
I am currently working on a simple VBA macro wich collects some metadata (e.g. EntryId, ReceivedTime, Recipients etc...) of mails in an Outlook mailbox.
To accomplish this it iterates through all folders recursively and collects the data from MailItems in every folder.
But I'm getting errors, which are not restricted to the same object (sometimes the error pops up earlier, but never later), stating the object does not support automation (runtime error 430).
The strange thing is, that roughly 14000 MailItems are processed without failure and usually at number 14232 it crashes.
I have two questions regarding this error:
I am working on a non local mailbox, therefore only a part of the data should be cached in the local .ost file.Could data missing in the cache be the cause for the error?
And if the cache is not the problem, then what is wrong with my code?
A simplified version of the code:
(Please note that all non MailItem objects are ruled out via an explicit typecheck)
Sub cache()
Dim objOl As Outlook.Application
Dim objNs As Outlook.NameSpace
Dim folder As Outlook.MAPIFolder
Dim vFolders As Outlook.Folders
Set objOl = New Outlook.Application
Set objNs = objOl.GetNamespace("MAPI")
Set vFolders = objNs.Folders
'This is where we're looking for the mailbox to work with
For i = 1 to vFolders.count
If StrComp(vFolders(i), "The Mailbox") = 0 Then
walk vFolders(i)
End If
Next
End Sub
Sub walk(folder As Outlook.MAPIFolder)
Dim item As Object
Dim vItems As Outlook.Items
Set vItems = folder.Items
If vItems.count > 0 Then
For i = 1 to vItems.Count
Set item = vItems(i)
If item.class = 43 Then
'This is where the debugger shows the runtime error 430
Debug.Print item.EntryID & vbCrLf & item.ReceivedTime
End If
Next
End If
Dim vFolders as Outlook.Folders
Set vFolders = folder.Folders
If (vFolders.count > 0) Then
For i = 1 To vFolders.Count
walk vFolders(i)
Next
End If
End Sub
UPDATE:
I updated the code according to the suggestions. No multi-dot notation and no For Each loops, the performance increased but the problem keeps occuring at the exact same item, as soon as I try to access data like (subject, entryID or else).
Since your error is happening in the same mailitem every time, I would validate what item 14232 is. From my experience just because it validates as enum 43 (or olMail) doesn't mean that all of the data will be valid. Is there anything special about 14232?
Edit:
I am currently working on a project using vb and outlook mailitems. I just identified the Item.MessageClass property defines the sub mailitem type. When I attempt to cast a message with a MessageClass other than IPM.Note it will give me a 430 error. Some of the MessageClass values that have given me problems include IPM.Note.Rues.ReplyTemplate.Microsoft and IPM.Note.Rules.OofTemplate.Microsoft. When I break on these messages I can see that most of the item's properties are not available. I would add an if check on your loop like this:
If item.class = 43 then
If item.messageclass = "IPM.Note" Then
Debug.Print item.EntryID & vbCrLf & item.ReceivedTime
End If
End If
this will then only print the info for normal messages. You may want to do some debugging on the MessageClass properties that you are currently able to process and see if they are all IPM.Note or if you can pinpoint the sub-type that is causing your problem.
Note: I do see that these mailitems still have a valid EntryID and ReceivedTime so I am not sure what the problem might be. What line of the code is your error occurring? The assignment of vItems(index) to Item? or is it somewhere else?
Firstly, avoid using multiple dot notation. Secondly, try not to use "for each" loops - they keep the collection items referenced until the loop exits. Do not use MailItem.Close - it does nothing unless you are actually showing the item in an Inspector.
dim vItems as Outlook.Items
vItems = folder.Items
for I = 1 to vItems.Count
set item = vItems.Item(I)
if item.Class = 43 Then
Debug.Print item.EntryID & vbCrLf & item.ReceivedTime
End If
set item = Nothing
Next
Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 4 years ago.
Improve this question
I have written a message handler function in Outlook's Visual Basic (we're using Outlook 2003 and Exchange Server) to help me sort out incoming email.
It is working for me, except sometimes the rule fails and Outlook deactivates it.
Then I turn the rule back on and manually run it on my Inbox to catch up. The rule spontaneously fails and deactivates several times a day.
I would love to fix this once and for all.
This code showed me the different TypeNames that were in my Inbox:
Public Sub GetTypeNamesInbox()
Dim myOlItems As Outlook.Items
Set myOlItems = application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
Dim msg As Object
For Each msg In myOlItems
Debug.Print TypeName(msg)
'emails are typename MailItem
'Meeting responses are typename MeetingItem
'Delivery receipts are typename ReportItem
Next msg
End Sub
HTH
I use the following VBA code snippet in other Office Applications, where the Outlook Library is directly referenced.
' Outlook Variables
Dim objOutlook As Outlook.Application: Set objOutlook = New Outlook.Application
Dim objNameSpace As Outlook.NameSpace: Set objNameSpace = objOutlook.GetNamespace("MAPI")
Dim objFolder As MAPIFolder: Set objFolder = objNameSpace.PickFolder()
Dim objMailItem As Outlook.MailItem
Dim iCounter As Integer: iCounter = objFolder.Items.Count
Dim i As Integer
For i = iCounter To 1 Step -1
If TypeOf objFolder.Items(i) Is MailItem Then
Set objMailItem = objFolder.Items(i)
With objMailItem
etc.
have written a message handler function in Outlook's Visual Basic (we're using Outlook 2003 and Exchange Server) to help me sort out incoming email. It is working for me, except sometimes the rule fails and Outlook deactivates it. Then I turn the rule back on and manually run it on my Inbox to catch up. The rule spontaneously fails and deactivates several times a day. I would love to fix this once and for all.
Here is the code stripped of the functionality, but giving you an idea of how it looks:
Public WithEvents myOlItems As Outlook.Items
Public Sub Application_Startup()
' Reference the items in the Inbox. Because myOlItems is declared
' "WithEvents" the ItemAdd event will fire below.
' Set myOlItems = Outlook.Session.GetDefaultFolder(olFolderInbox).Items
Set myOlItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub myOlItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
If TypeName(Item) = "MailItem" Then
MyMessageHandler Item
End If
End Sub
Public Sub MyMessageHandler(ByRef Item As MailItem)
Dim strSender As String
Dim strSubject As String
If TypeName(Item) <> "MailItem" Then
Exit Sub
End If
strSender = LCase(Item.SenderEmailAddress)
strSubject = Item.Subject
rem do stuff
rem do stuff
rem do stuff
End Sub
One error I get is "Type Mismatch" calling MyMessageHandler where VB complains that Item is not a MailItem. Okay, but TypeName(Item) returns "MailItem", so how come Item is not a MailItem?
Another one I get is where an email with an empty subject comes along. The line
strSubject = Item.Subject
gives me an error. I know Item.Subject should be blank, but why is that an error?
Thanks.
My memory is somewhat cloudy on this, but I believe that a MailItem is not a MailItem when it is something like a read receipt. (Unfortunately, the VBA code that demonstrated this was written at another job and isn't around now.)
I also had code written to process incoming messages, probably for the same reason you did (too many rules for Exchange, or rules too complex for the Rules Wizard), and seem to recall running into the same problem you have, that some items seemed to be from a different type even though I was catching them with something like what you wrote.
I'll see if I can produce a specific example if it will help.
There are many types of items that can be seen in the default Inbox.
In the called procedure, assign the incoming item to an Object type variable. Then use TypeOf or TypeName to determine if it is a MailItem. Only then should your code perform actions that apply to emails.
i.e.
Dim obj As Object
If TypeName(obj) = "MailItem" Then
' your code for mail items here
End If
Dim objInboxFolder As MAPIFolder
Dim oItem As MailItem
Set objInboxFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For Each Item In objInboxFolder.Items
If TypeName(Item) = "MailItem" Then
Set oItem = Item
next
why not use a simple error handler for the code? Seriously. You could write an error for each read of a property or object that seems to fail. Then have it Resume no matter what. No need for complex error handling. Think of a test that shows an empty subject. Since you don't know what value it will return, if any, and it seems to error on an empty or blank subject, you need to picture it as a simple test with a possible error. Run the test as an if statement (one in which you will get an error anyway), and have the program resume on error.
On Error Resume Next
If object.subject = Null 'produces an error when subject is null, otherwise allows a good read
strSubject = "" 'sets the subject grab string to a null or empty string as a string
Else
strSubject = object.subject 'Sets the subject grab string to the subject of the message\item
End If