Run rule from VBA fails - vba

I want to be able to run a rule from a macro/button in ribbon instead of going through all the clicks needed to "Run rules now" manually. Using Outlook 2016.
I have tried to make the most simple VBA script in order to do that. For some reason, my Outlook rule is stored in the second store and not the default store.
When running the macro, the MsgBox is prompted, so the rule is found but it is not executed, and the e-mails in target are not moved as they should.
How can I improve my code in order to actually execute the rule.
Sub RunRule()
Dim rules As Outlook.rules
Set rules = Application.Session.Stores(2).GetRules()
rules.Item("kundeordre").Execute ShowProgress:=True
MsgBox rules.Item("kundeordre")
End Sub
The rules in Outlook:

For rules in a non-default store, specify the folder.
Option Explicit
Sub RunRule()
' https://learn.microsoft.com/en-us/office/vba/api/outlook.rule.execute
Dim olRules As rules
Dim myRule As Rule
Dim myRuleName As String
Dim olStore As Store
Dim olFolder As Folder
Set olStore = Session.Stores(2)
Debug.Print olStore
With olStore
Set olRules = .GetRules()
Set olFolder = .GetDefaultFolder(olFolderInbox)
End With
myRuleName = "kundeordre"
For Each myRule In olRules
Debug.Print "myRule " & myRule
If myRule = myRuleName Then
' Folder required for non-default store
myRule.Execute ShowProgress:=True, Folder:=olFolder
MsgBox myRule & " executed in " & olStore
Exit For
End If
Next
End Sub

Related

Move specific mails from one folder to another

in Outlook I would like to have a FollowUp-Solution that checks a specific folder (Source Folder) if there are mails older than 1 days and moves them in another specific folder (Target Folder).
My problem is that it seems as my code isn't looping the SourceFolder properly. Some mails are moved but some old mails are still in the SourceFolder.
When I restart the Code some of the remaining mails are moved now but still some remain in the SourceFolder.
I tried to loop the Items in other ways (with; for each; do) but I guess my vba understanding is too bad to get a working solution.
Sub MoveFollowUpItems()
Dim FolderTarget As Folder
Dim FolderSource As Folder
Dim Item As Object
Dim FolderItems As Outlook.Items
Set FolderTarget = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set FolderSource = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("FollowUp")
Set FolderItems = FolderSource.Items
For Each Item In FolderItems
If Item.ReceivedTime < Date - 1 Then '
Item.Move FolderTarget
End If
Next
End Sub
Does anyone know how to handle the propper looping?
For Each Loop is a great but When moving/deleting items Loop Through in Reverse Order you know count down (ie 3,2,1). In order to do this, you can incorporate Step -1 into your loop statement.
Also to improve your loop try using Items.Restrict Method (Outlook) on your date filter
Example
Option Explicit
Sub MoveFollowUpItems()
Dim FolderTarget As Folder
Dim FolderSource As Folder
Dim FolderItems As Outlook.Items
Set FolderTarget = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set FolderSource = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("FollowUp")
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " <= 'Date - 1' "
Set FolderItems = FolderSource.Items.Restrict(Filter)
Debug.Print FolderItems.Count
Dim i As Long
For i = FolderItems.Count To 1 Step -1
Debug.Print FolderItems(i) 'Immediate Window
' FolderItems(i).Move FolderTarget
Next
End Sub

VBA script that maps https to \\ paths for downloads

I wrote a script to download files using VBA. The VBA script has to download items that start with https://collaboration.company.corp/collrooms/specificfolder or with \collaboration.company.corp#SSL\DavWWWRoot\collrooms\specificfolder
The specific folders are the same.
If I allow the script to select the specific mapping, it will only recognize it if I use the definition \collaboration.company.corp#SSL\DavWWWRoot\collrooms\specificfolder
How can I create a mapping in VBA to tell Excel that https://collaboration.company.corp/collrooms/specificfolder and \collaboration.company.corp#SSL\DavWWWRoot\collrooms\specificfolder is the same and that the first specification is also valid?
My code:
Option Explicit
Sub FolderSelection()
'Shows the folder picker dialog in order the user to select the folder
'in which the downloaded files will be saved.
Dim FoldersPath As String
'Show the folder picker dialog.
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder to save your files..."
.Show
If .SelectedItems.Count = 0 Then
Sheets("Main").Range("B4") = "-"
MsgBox "You did't select a folder!", vbExclamation, "Canceled"
Exit Sub
Else
FoldersPath = .SelectedItems(1)
End If
End With
'Pass the folder's path to the cell. HERE I AM MISSING THE MAPPING. It will show files starting with https if selected and not transfer it to the other structure.
Sheets("Main").Range("B4") = FoldersPath
End Sub
Sub Clear()
'Clears the URLs, the result column and the folder's path.
Dim LastRow As Long
'Find the last row.
With Sheets("Main")
.Activate
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
'Clear the ranges.
If LastRow > 7 Then
With Sheets("Main")
.Range("C8:D" & LastRow).ClearContents
.Range("B4:D4").ClearContents
.Range("B4").Select
End With
End If
End Sub
and the other part of the download macro is
'Check if the folder exists. I did not check whether it will also download with the https structure?
DownloadFolder = sh.Range("B4")
On Error Resume Next
If Dir(DownloadFolder, vbDirectory) = vbNullString Then
MsgBox "The path is incorrect!", vbCritical, "Folder's Path Error"
sh.Range("B4").Select
Exit Sub
End If
On Error GoTo 0
I tried with a script that I found on Stackoverflow but it does not work
I created an additional module:
Sub test()
Dim dm As New DriveMapper
Dim sharepointFolder As Scripting.Folder
Set sharepointFolder = dm.MapDrive("https://collaboration.company.corp/collrooms/")
' unsure whether I have to add something here and whether this will work with https
Debug.Print sharepointFolder.Path
End Sub
and added the following WebDAV mapping as a new CLASS
Option Explicit
Private oMappedDrive As Scripting.Drive
Private oFSO As New Scripting.FileSystemObject
Private oNetwork As New WshNetwork
Private Sub Class_Terminate()
UnmapDrive
End Sub
Public Function MapDrive(NetworkPath As String) As Scripting.Folder
Dim DriveLetter As String, i As Integer
UnmapDrive
For i = Asc("Z") To Asc("A") Step -1
DriveLetter = Chr(i)
If Not oFSO.DriveExists(DriveLetter) Then
oNetwork.MapNetworkDrive DriveLetter & ":", NetworkPath
Set oMappedDrive = oFSO.GetDrive(DriveLetter)
Set MapDrive = oMappedDrive.RootFolder
Exit For
End If
Next i
End Function
Private Sub UnmapDrive()
If Not oMappedDrive Is Nothing Then
If oMappedDrive.IsReady Then
oNetwork.RemoveNetworkDrive oMappedDrive.DriveLetter & ":"
End If
Set oMappedDrive = Nothing
End If
End Sub
The question is also whether removing the dispose method "Class_Terminate" which unmaps the drive would help? When the class goes out of scope then the drive get's unmapped. And how I could put it all together.

Outlook template rule to sort mails among directories

I have folders created for different projects (e.g. Proj1, Proj2, Proj3, ...).
It is general convention in the department to sent emails concerning specific project with its name in the subject (e.g. "Proj1: project finished!").
I know that I can create rules for every project to move mails that contain its name to the project folder. However, I would need to create as many rules as the number of folders I have - so its not very convenient and optimal.
Is there any way to create a rule (a single rule) (possibly, with VBA code) that will contain list of all folder names, search for any name from the list among mails' subjucts and automatically move mail to the corresponding folder?
In order to achieve exactly what you want you can use this macro:
Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder
For Each fldr In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders
If m.Subject Like "*" & fldr.Name & "*" Then m.Move fldr
Next
Set fldr = Nothing
End Sub
This macro can be triggered by arrival of a new email if you add to ThisOutlookSession module these lines:
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim o As Object
Set o = Application.Session.GetItemFromID(EntryIDCollection)
If TypeName(o) = "MailItem" Then RulesForFolders o
Set o = Nothing
End Sub
Though, I would recommend you get rid of the folders where you move your messages to. Instead, you can use keep all you messages in Inbox and use Search folders to group them in whatever order you want. This way you can quickly search through all your inbox and sort it as well as separate search folders. You can also have the same message in different folders not duplicating it. If you decide to do so, your macro will need to assign categories instead of moving messages:
Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder, str As Outlook.Store
For Each str In Application.Session.Stores
For Each fldr In str.GetSearchFolders
If m.Subject Like "*" & fldr.Name & "*" Then
m.Categories = m.Categories & "," & fldr.Name
m.Save
End If
Next
Next
Set fldr = Nothing
Set str = Nothing
End Sub
I needed the rule to process subfolders, so I have slightly modified the previous answer of #Vladislav Andreev:
Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder
For Each fldr In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders
If LCase(m.Subject) Like "*" & LCase(fldr.Name) & "*" Then
m.Move fldr
Exit For
End If
For Each subFldr In fldr.Folders
If LCase(m.Subject) Like "*" & LCase(subFldr.Name) & "*" Then
m.Move subFldr
Exit For
End If
Next
Next
Set fldr = Nothing
Set subFldr = Nothing
End Sub

VBA project works fine on machine with outlook 2013, but not on a machine running outlook 2010

Both machines are running 64 bit versions of Win7. The project has been painfully pieced together, I am not a programmer.
The function of the project is to automatically search emails for attachments upon a reminder set to fire every night and only download attachments to specified pathway that have the string defined by the two "pos" lines of code. Basically it just checks if the file name contains the desired name/phrase. The files I am working with change slightly with every email and over the years, but always contains the one statement. If the mail was unRead, it marks it as read when it is done with all the attachments in each email.
The only other difference is the machine with outlook 2010 does have some other code running on it. I placed this code on the machine with outlook 2013 to see if it was conflicting, but it ran perfectly still.
The following code works beautifully on the machine with outlook 2013, but not at all on the machine with outlook 2010. The project compiles just fine, and "runs" but does not download any files nor mark any emails as unread.
Here is the code in "This Outlook Session"
Private WithEvents MyReminders As Outlook.Reminders
Private Sub Application_Startup()
Set MyReminders = GetOutlookApp.Reminders
End Sub
Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Outlook.Application
End Function
Private Sub MyReminders_ReminderFire(ByVal ReminderObject As Reminder)
'On Error GoTo ErrorHandler
If ReminderObject.Caption = "Daily Report" Then
ReminderObject.Dismiss
Daily_Report
End If
If ReminderObject.Caption = "Shutdown Outlook" Then
ReminderObject.Dismiss
Application.Quit
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
And Here is the code I have on Module1, this is only because of the pre-existing code on the other machine. I know it doesnt have to be in the module. Here it is:
Sub Daily_Report()
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro.
On Error GoTo GetAttachment_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileNameXLS As String
Dim FileNamePDF As String
Dim posXLS As Integer
Dim posPDF As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
' Check each message for attachments
For Each Item In Inbox.Items
' Save any attachments found
If Item.UnRead = True Then
For Each Atmt In Item.Attachments
posXLS = InStr(Atmt.FileName, "FINAL EXCEL")
posPDF = InStr(Atmt.FileName, "Final PDF")
If posXLS <> 0 And (Right(Atmt.FileName, 4) = ".xls") Or posXLS <> 0 And (Right(Atmt.FileName, 5) = ".xlsx") Then
FileNameXLS = "C:\Users\ba\Downloads\Babcok Lab Reports\Babcock Excel\" & Atmt.FileName
Atmt.SaveAsFile FileNameXLS
End If
If posPDF <> 0 And (Right(Atmt.FileName, 4) = ".pdf") Then
FileNamePDF = "C:\Users\ba\Downloads\Babcok Lab Reports\Babcock PDF\" & Atmt.FileName
Atmt.SaveAsFile FileNamePDF
End If
Next Atmt
Item.UnRead = False
End If
Next Item
' Clear memory
GetAttachment_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle errors
GetAttachment_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!"
Resume Next
End Sub
You need to use the Application property in the code:
Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Application
End Function
Also I'd recommend debugging the code in the step-by-step manner. Nobody can help you until specify the exact error you get on the problematic machine.
I am not a programmer
The current web site is for developers, that's why I'd suggest learning the basics at least. See Getting Started with VBA in Outlook 2010.
Make sure that the Daily_Report sub is invoked correctly.
My code was looking at the Outlook Data File "Inbox" when all the mail was going into the gmail account Inbox that outlook was setup with. Once I redirected the mail into the "Data File Inbox" via an inbox "rule" the code worked beautifully. The Daily_Report subroutine is being invoked correctly and the application is being used properly. Alternatively, I probably could have redirected my code to look in the gmail inbox, but didn't know how to easily do this being an amateur in programming. Any suggestions for the alternate will be appreciated.

Outlook 2010 Macro throws VBA error 'For loop not initialized'

I got this bit of code from someone's blog years ago. It basically iterates through all the Outlook mail rules, and executes them (handy to organize your inbox!). I've recently upgrade to Outlook 2010 from 2007. Now I get a very strange error stating
Run-time error '92':
For loop not initialized
However, while debugging this, it will always run through 8 times (out of 20-25), then it throw this error.
Here is the offending code:
Sub RunAllInboxRules()
Dim st As Outlook.Store
Dim myRules As Outlook.Rules
Dim rl As Outlook.Rule
Dim count As Integer
Dim ruleList As String
'get default store (where rules live) & get rules
Set st = Application.Session.DefaultStore
Set myRules = st.GetRules
'iterate all the rules
For Each rl In myRules
If rl.RuleType = olRuleReceive Then 'determine if it’s an Inbox rule, if so, run it
rl.Execute ShowProgress:=True
count = count + 1
ruleList = ruleList & vbCrLf & rl.Name
End If
Next
'tell the user what you did
ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
MsgBox ruleList, vbInformation, "Macro: RunAllInboxRules"
Set rl = Nothing
Set st = Nothing
Set myRules = Nothing
End Sub
Edit:
Per Jay Riggs's comment, clearing the entire for block still results in the error.
I'd replace this loop with something like:
Dim k as Long
For k = 1 To myRules.Count ' might be 0-based, didnt check
set rl = myRules(k)
If rl.RuleType = olRuleReceive Then 'determine if it’s an Inbox rule, if so, run it
rl.Execute ShowProgress:=True
count = count + 1
ruleList = ruleList & vbCrLf & rl.Name
End If
Next
I bet there is some rule at position 8 or 9 that doesn't fit into the myRules collection and that throws the error. You can also check the myRules collection at the offending point. Maybe Office 2007 was more forgiving and skipped that entry.
So the issue ended up being that some of the rules referred to a PST file I missed on moving to my new machine. Thanks to Justin for forcing me to take a deeper look at the rules!
+1 to the obscure error message for this.