Why is this code to run all enabled rules does not run in outlook-2016?
I used it without any problem on outlook 2007, 2010 and 2013, but it is not working in outlook 2016.
Sub OrginalRunActiveCatInboxRules()
Dim Session As Outlook.NameSpace
Dim Report As String
Dim currentItem As Object
Dim currentRule As Outlook.Rule
Dim rules As Outlook.rules
Dim ruleList As String
Set Session = Application.Session
Set rules = Session.DefaultStore.GetRules()
For Each currentRule In rules
If currentRule.RuleType = olRuleReceive Then
'determine if it’s an Inbox rule, if so, run it
If currentRule.Enabled Then
If Left(currentRule.name, 4) = "Cat." Then
MsgBox currentRule.name
currentRule.Execute ShowProgress:=True
' Sortering niet laten zien
' ruleList = ruleList & vbCrLf & currentRule.Name
End If
End If
End If
Next
' tell the user what you did
' ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
' MsgBox ruleList, vbInformation, "Macro: RunAllActiveInboxRules"
Set rules = Nothing
Set currentRule = Nothing
End Sub
The codes runs until next, but gives a error there. It does not matter if the first rule is enabled or not, starts with Cat. or not. It just won't go to the next item in the loop, but generates a error.
What can I do to make the code working again?
Check in the rules wizard if some of the rules are marked 'From other computer'.
If you have any like this, then the code will break at the line:
For Each currentRule In rules
I have the same issue now - took me a lot of troubleshooting to figure this out. One more thing that could be an issue: if any of the rules are broken, for example refer to a directory that does not exist, the rules object will not contain any rules.
If troubleshooting the above, remove all the suspicious rules and start adding them one by one back.
One of mine was marked "on this computer" when I unselected this option, the script worked again.
Related
I previously asked about getting rules to work on multiple accounts. It was partially answered, however rules do not work on the second account.
When running the script the progress window pops up, but no rules run.
Debug output of the rules lists all the rules for the account. If I manually run the rules, it does work.
Decided to split the macro into two. Running the first macro works for the first account. But the second macro for the second account doesn't work.
My assumption is it is trying to run those rules on the first account, but not succeeding because those rules do not exist.
Sub RunTest_AccountOne()
Dim storeRules As Rules
Dim storeRule As Rule
Dim allStores As Stores
Dim myStore As Store
Dim emailaccount As String
Set allStores = Session.Stores
emailaccount = "example#example.com.au"
For Each myStore In allStores
'On Error Resume Next
'If needed, place just before the expected error.
'Follow closely with On Error GoTo 0 to return to normal error handling.
'Debug.Print myStore.DisplayName & " " & myStore.ExchangeStoreType
Select Case myStore.DisplayName
Case emailaccount
'Debug.Print " ExchangeStoreType matched: " _
& myStore.DisplayName & " " & myStore.ExchangeStoreType
Set storeRules = myStore.GetRules()
For Each storeRule In storeRules
'Below only works if it is the first account added to Outlook.
'storeRule.Execute 'ShowProgress:=False
'Below shows the progress window for rules running, but doesn't apply anything.
storeRule.Execute ShowProgress:=True, Folder:=myStore.GetDefaultFolder(olFolderInbox), RuleExecuteOption:=olRuleExecuteAllMessages
'Below outputs a bunch of "Inbox" messages in the console, which coincides with the amount of rules, as expected.
'Debug.Print myStore.GetDefaultFolder(olFolderInbox)
Next
End Select
Next
End Sub
I have tried with RuleExecuteOption:=olRuleExecuteAllMessages and without.
I receive 4 weekly emails from 3 different senders.
Emails 1 and 2 are from the same sender and can be recognized through VBA. These emails contain zip files, where each zip file has one .csv file.
Emails 3 and 4 can also be recognized by VBA and the attachments are Excel sheets (.xlsx).
I want to extract and unzip (where needed) and save these 4 files in a folder as; email1.report, email2.report etc.
Then make a copy of these 4 files in a different folder for each file and rename like; "Today's date".email1.report.csv etc.
I want to combine these steps in a single code and to replace the email1.report, email2.report etc., files without a prompt asking "do you want to replace the files? Yes, No?"
Is it possible to detect the new weekly emails and do this automatically?
The code I use to unzip and save:
Else
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "zip" Then
FileNameFolder = "C:\Users\..."
FileName = FileNameFolder & Left(Atmt.FileName, (InStr(1, Atmt.FileName, ".zip") - 1)) & ".txt"
Atmt.SaveAsFile FileName
FileNameT = FileNameFolder & Atmt.FileName
Name FileName As FileNameT
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((FileNameT)).Items
Kill FileNameT
i = i + 1
End If
Next Atmt
'item.Close
End If
I won't develop the code for your specific problem, but I recently wrote something similar. Maybe you can go from here by altering to your criteria etc.
In my case I had two e-mails incoming shortly after another, within 60 seconds. Both mails had "FP" in their subject and a .pdf-attachment. The task was to concatenate these attachments using the installed PDF24, which luckily offers a shell command for this.
This was the code, placed in the "ThisOutlookSession" of the Outlook VBA project explorer.
Public btAttachmentMails As Byte
Public dtArrivalStamp As Date
Public strPathFirstMailAttachment As String
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
If TypeName(Item) = "MailItem" Then
Dim i As Integer
Dim strDocumentsFolder As String
strDocumentsFolder = CreateObject("WScript.Shell").SpecialFolders(16)
strPathFirstMailAttachment = strDocumentsFolder & "\attachment_mail1.pdf"
If Item.Subject Like "FP*" Then
If btAttachmentMails = 0 Then
'first mail -> save attachment and set counter to 1
btAttachmentMails = 1
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment
End If
Next i
ElseIf btAttachmentMails = 1 Then
Dim dtNow As Date: dtNow = Time
If TimeDiff(dtArrivalStamp, dtNow) <= 60 Then
'second mail within 60 seconds with subject containing "FP" -> save attachment and concatenate both via pdf24, then delete both files
'save attachment of second mail
Dim strPathSecondMailAttachment As String
strPathSecondMailAttachment = strDocumentsFolder & "\attachment_mail2.pdf"
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathSecondMailAttachment
End If
Next i
'concatenate pdf documents via pdf24 shell
Dim strOutputPath As String
strOutputPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Year(Date) & Month(Date) & Day(Date) & "_Wartungsplan_" & Replace(CStr(Time), ":", "-") & ".PDF"
Shell ("""C:\Program Files (x86)\PDF24\pdf24-DocTool.exe"" -join -profile ""default/good"" -outputFile " & strOutputPath & " " & strPathFirstMailAttachment & " " & strPathSecondMailAttachment)
'inform user
MsgBox ("Files have been successfully concatenated. You can find the combined file on your desktop.")
'reset status, delete temporary documents
btAttachmentMails = 0
If CreateObject("Scripting.FileSystemObject").fileexists(strPathFirstMailAttachment) Then Kill strPathFirstMailAttachment
If CreateObject("Scripting.FileSystemObject").fileexists(strPathSecondMailAttachment) Then Kill strPathSecondMailAttachment
Else
'second mail did not arrive within 60 seconds -> treat as first mail
'save new arrival time and overwrite old firstMailAttachment with this one
dtArrivalStamp = Time
For i = 1 To Item.Attachments.Count
If InStr(Item.Attachments.Item(i).DisplayName, ".PDF") > 0 Then
Item.Attachments.Item(i).SaveAsFile strPathFirstMailAttachment 'overwrites existing file
End If
Next i
End If
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & " - please contact XY"
Resume ExitNewItem
End Sub
Function TimeDiff(StartTime As Date, StopTime As Date)
TimeDiff = Abs(StopTime - StartTime) * 86400
End Function
cr44sh has posted an answer while I was creating mine. He has recommended using a new item event while I have recommended using a rule. I prefer rules but you can choose which ever approach you favour.
It is impossible to fully answer your question but I believe I can give enough help for you to construct the macros you need yourself.
You say that these emails can be identified with VBA. That suggests the best approach is an Outlook rule which uses the “run a script” option where “run a script” means “run a macro”. I will discuss the rule later but first you need the macros that will be run.
You will need two macros like this:
Public Sub Type1Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub
Public Sub Type2Email(ByRef ItemCrnt As MailItem)
' Relevant code
End Sub
I am sure you can create better names for these macros. I have read that macros to be run by a rule must be in ThisOutlookSession. In my experience, they can be in an ordinary module providing they are declared as Public. I only use ThisOutlookSession for code that has to be in that code area. If code can be in a module, that is where I place it. I suggest creating a new module which will be named Module1 or Module2. Use function key F4 to access its properties and rename it as “ModRuleMacros” or similar. Giving modules meaningful names makes it so much easier to find the code you want to look at today.
Although the aim is to create a macro to be run by a rule, you need a way of testing the macro. If you have some of these emails saved somewhere, you can activate the rule by moving one of those emails to Inbox. However, I generally find it easier to use a macro like this:
Sub TestType1Email()
Dim Exp As Explorer
Dim ItemCrnt As MailItem
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Pleaase select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
Call Type1Email(ItemCrnt)
Next
End If
End Sub
To use this macro, you select one or more Type1 emails and then run macro TestType1Email. This macro will pass the selected emails, one at a time, to the macro Type1Email. This will allow you to single step through macro Type1Email and ensure that it works to your entire satisfaction. I find this to be the easier method of testing a new Outlook macro.
It may be helpful to check what a rule can do for you. Select one of these emails and then click on Rules, which is in the middle of the Home tab, and then Create rule …. Selecting one of these emails means the first window is filled out with some options. Click Advanced options …. The new window lists all the options for selecting an email. Are all the options you need to select a type 1 or a type 2 email listed? The list is comprehensive but not complete. For example, you cannot select by the presence of attachments. Identify the options you can use and identify the options you need that are missing. Click Cancel twice to exist from rule creation.
You will need include code for any missing options in your macro.
Your question implies you have all the code you need for processing the emails except for suppressing the replace question. You need to check if there is an existing file before creating the new file. This is the routine that I use to check if a file exists:
Public Function FileExists(ByVal PathName As String, ByVal FileName As String) As Boolean
' Returns True if file exists. Assumes path already tested.
' Coded by Tony Dallimore
' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283
' Ensure only one "\" between path and filename
If Right$(PathName, 1) <> "\" Then
PathName = PathName & "\"
End If
If Left$(FileName, 1) = "\" Then
FileName = Mid$(FileName, 2)
End If
FileExists = False
On Error Resume Next
FileExists = ((GetAttr(PathName & FileName) And vbDirectory) <> vbDirectory)
On Error GoTo 0
End Function
If the file exists, you can:
Use VBA statement Kill (https://learn.microsoft.com/en-gb/office/vba/Language/Reference/user-interface-help/kill-statement) to delete the old file.
Use VBA statement Name (https://learn.microsoft.com/en-gb/office/vba/language/reference/user-interface-help/name-statement) to move the old file to another folder or rename it perhaps by adding a date at the beginning of the name.
I favour the second option because I do not like deleting a file until I am really, really sure I will not need it again. I saw too many situations during my career where a file deleted as no longer needed was found to be incorrectly or incompletely processed a few months later.
Once you have fully tested the macros, you can create the rules to execute them. For each type of email:
Select an email of the required type.
Click on Rules and then Create rule ….
Tick any relevant boxes on the first window.
Click Advanced options ….
Tick all relevant boxes on the second window.
Click Next.
Tick the box against “Run a script”.
Click a script.
You will be shown a list of all the macros that can be run from a rule. Select the required macro.
Click Next.
Tick the box against any appropriate exceptions and enter any additional information required.
Click Next.
Name the rule. Tick “run this rule against any messages already in Inbox” if required. Review the rule and edit if necessary.
Click Finish.
I hope the above is enough to plug the holes in your knowledge.
Trying to run a rule to move emails upon arrival from first public email box to second public email box.
Rule is: Apply this rule after the message arrives | Sent to "first public email box" | move it to the "second public email box" folder.
Rule works when run manually but the rule does not work automatically upon emails arriving (research shows there might be some corrupt file, ...).
Trying to make it work via VBA instead. Below macro supposed to run the rules upon a reminder popping up. Reminder pops up, but rules don't run.
Running that macro from a QAT custom button, brings up progress window, and that window shows progress, but emails are still in the first public email box.
Private Sub Application_Reminder(ByVal Item As Object)
If Item.MessageClass <> "IPM.Task" Then
Exit Sub
End If
If Item.Subject = "Run Rules" Then
RunRules
End If
End Sub
Sub RunRules()
Dim olRules As Outlook.Rules
Dim myRule As Outlook.Rule
Dim olRuleNames() As Variant
Dim name As Variant
olRuleNames = Array("Rule A", "Rule B")
Set olRules = Application.Session.DefaultStore.GetRules()
For Each name In olRuleNames()
For Each myRule In olRules
' Rules we want to run
If myRule.name = name Then
myRule.Execute ShowProgress:=True
End If
Next
Next
End Sub
The use of DefaultStore is a hint there are stores other than the default.
Set olRules = Application.Session.DefaultStore.GetRules()
Option Explicit
Private Sub FindStoreWithRules()
Dim colStores As stores
Dim oStore As store
Dim olRules As rules
Dim myRule As Rule
Dim i As Long
Set colStores = Session.stores
For i = 1 To colStores.count
Debug.Print i & ": " & colStores(i)
' On second run
' Enter applicable name then uncomment this line and the End If
' If colStores(i) = "Name of store shown in immediate window" Then
On Error Resume Next
' Where rules not applicable on some stores there is an error.
Set olRules = colStores(i).GetRules()
' Discontinue error bypass as soon as the purpose is served
On Error GoTo 0
If Not olRules Is Nothing Then
For Each myRule In olRules
' Uncomment on second run to see if what rules were found
'Debug.Print " - " & myRule.name
Next
Else
Debug.Print "Rules not applicable in " & colStores(i)
End If
' End If
Next
Debug.Print "Done."
End Sub
Can anyone help me figure out what's going wrong and how to fix it?
I'm trying to automate sending an email with some daily status information. I'd tried automating this from Access but kept running into (known but apparently unsolved) problems with GetObject(, "Outlook.Application") with Windows 8.1 64 and Outlook 2013. So I decided to automate starting from Outlook.
Anyway, I moved the mail message creation code into Outlook vba and had it start Access and run the Access code. This is all well and good until I get to creating the mail message. Everything starts just fine until it gets to writing to the body of message (using Word as the body editor). At the first "TypeText" command, I'm getting the error message in the title. If I click debug on the error notification dialog and then single-step through the line of code in question, it works just fine. I thought that there was some timing problem, so I stuck a 2-second wait in the code. No luck. The code in question, with some other oddities associated with testing (notably trying to type and then delete text), is below:
Public Sub CreateMetrics()
' Mail-sending variables
Dim mailApp As Outlook.Application
Dim accessApp As Access.Application
Dim mail As MailItem
Dim wEditor As Word.Document
Dim boolCreatedApp As Boolean
Dim i As Integer
Set mailApp = Application
' Create an Access application object and open the database
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDatabase dbLoc
accessApp.Visible = True
' Open the desired form and run the click event hander for the start button
accessApp.DoCmd.OpenForm ("ProcessStatus")
accessApp.Forms![ProcessStatus].StartButton_Click
' Create the outgoing mail message
Set mail = Application.CreateItem(olMailItem)
mail.Display
mail.BodyFormat = olFormatHTML
Set wEditor = mailApp.ActiveInspector.WordEditor
With accessApp.Forms![ProcessStatus]
Debug.Print .lblToList.Caption
Debug.Print .lblSubject.Caption
Debug.Print .lblIntroduction.Caption
Debug.Print .lblAttachFilepath.Caption
End With
mail.To = accessApp.Forms![ProcessStatus].lblToList.Caption
mail.Recipients.ResolveAll
mail.Subject = accessApp.Forms![ProcessStatus].lblSubject.Caption
mail.Attachments.Add accessApp.Forms![ProcessStatus].lblAttachFilepath.Caption
Sleep 2000
' Error occurs in the next line ***********************************************
wEditor.Application.Selection.TypeText Text:="Test"
wEditor.Application.Selection.HomeKey
wEditor.Application.Selection.Delete Count:=4
wEditor.Application.Selection.PasteSpecial DataType:=wdPasteBitmap
wEditor.Application.Selection.HomeKey
wEditor.Application.Selection.TypeText accessApp.Forms![ProcessStatus].lblIntroduction.Caption
wEditor.Application.Selection.TypeText Text:=Chr(13) & Chr(13)
wEditor.Application.Selection.EndKey
' wEditor.Application.Selection.EndKey
' wEditor.Application.Selection.TypeText Text:=Chr(13)
' wEditor.Application.Selection.TypeText Text:=configs("EmailSignature")
' End With
With mailApp.Session.Accounts
i = 1
Do While i <= .Count
' Use either the specified email address OR the last outlook email address
If RegEx_IsStringMatching(.Item(i).SmtpAddress, accessApp.Forms![ProcessStatus].lblSenderRegex.Caption) Or i = .Count Then
mail.SendUsingAccount = .Item(i)
i = .Count + 1
Else
i = i + 1
End If
Loop
End With
mail.Save
accessApp.Quit
End Sub
I added a "mail.Display" just before the line that was causing the failure, which seemed, incorrectly, to have fixed the problem.
I have now solved this problem by executing a document.select on the document associated with the email I was creating. To select the right document (there doesn't seem to be any guarantee of which one that would be within the wEditor.Application.Documents collection, though it was typically the first one), I created an almost-certainly unique piece of text and assigned it to the body of the email, which I could then go and find. Here's the new code that I added to the code above:
Dim aDoc As Word.Document
Dim strUniqueID As String
. . .
mail.Attachments.Add accessApp.Forms![ProcessStatus].lblAttachFilepath.Caption
strUniqueID = accessApp.Forms![ProcessStatus].lblSubject.Caption & Rnd(Now()) & Now()
mail.Body = strUniqueID
' Search for the unique text. aDoc.Content has extra characters at the
' end, so compare only for the length of the unique text
For Each aDoc In wEditor.Application.Documents
If Left(aDoc.Content, Len(strUniqueID)) = strUniqueID Then
aDoc.Select
mail.Body = ""
End If
Next aDoc
wEditor.Application.Selection.TypeText Text:="Test"
. . .
I looked at a lot of examples of code that did this kind of thing. None of them performed a select or said anything about needing one. Debugging was made that much harder because the select occured implicitly when the debugger was invoked.
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