Loop to set up watches on a selection of Outlook folders - vba

Question

I'm doing the following in VBA in Outlook. Upon dragging an Outlook item to a specified folder, I save this Outlook item to my computer (i.e. a filing system).
Private WithEvents Items As Outlook.Items
Private WithEvents Items2 As Outlook.Items
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set Items = Ns.GetDefaultFolder(olFolderInbox).Parent.Folders("Hello").Items
Set Items2 = Ns.GetDefaultFolder(olFolderInbox).Parent.Folders("Bye").Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
sName = Item.Subject
ReplaceCharsForFileName sName, "_"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, " - hhnn ", _
vbUseSystemDayOfWeek, vbUseSystem) & "- " & sName & ".msg"
sPath = "Y:\BM_Clientenmap\D\Hello\emails\"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End If
End Sub
Private Sub Items2_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
sName = Item.Subject
ReplaceCharsForFileName sName, "_"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, " - hhnn ", _
vbUseSystemDayOfWeek, vbUseSystem) & "- " & sName & ".msg"
sPath = "Y:\BM_Clientenmap\D\Bye\emails\"
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End If
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
This code saves an Outlook item to the computer in directory sPath (Sub Items/Items2_AddItem), if the user adds a file to the directory specified in the variable Items/Items2 declared at the top.
The problem is it requires me to manually add in VBA which folders VBA should "watch" when an item is added, and where to save these files. As a result, it requires me to write a new Items variable and new Items_ItemAdd sub for every folder I have.
I want to do the following:
Select the folder that should be "watched" for an item added, and the folder to which it should be saved, through user interface in Outlook instead of VBA. Users should select multiple folders (I don't care if they have to select them one at a time), with multiple save folders on the computer.
I want Outlook to remember the choices that the user made upon closing Outlook.
To make it more user friendly, I thought about the following.
User selects folder in Outlook. Code that I found that does this:
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
User then selects the folder the item should be saved to on computer. Code that I found that allows you to set a variable to an input filepath:
Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
Dim objShell As Object
Dim objFolder ' As Folder
Dim enviro
enviro = CStr(Environ("USERPROFILE"))
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0,
enviro & "\Computer\")
StrSavePath = objFolder.self.Path
On Error Resume Next
On Error GoTo 0
ExitFunction:
Set objShell = Nothing
End Sub
I want the above code to run when the user presses a button in the ribbon to which my macro would be set.
I want Outlook to watch these folders that the user has selected (i.e. what Sub Items_ItemAdd does). This is where I get stuck. I want the choices of the user to be remembered (i.e. so the user doesn't have to select his folders every time he opens Outlook) after Outlook is closed.
Now my questions are as follows:
I imagined one way to make this work is to create a new variable Items(i) and a new Sub Items(i)_ItemAdd directly in the VBA code every time the user selects the folder and save folder. However, I read this is impossible to do in Outlook, unlike in Excel. Is this true? If not: how to create VBA code using VBA in Outlook?
Another way I can imagine is the following. I save the input that the user made to a text file, and I read from the text file and save that to an array. However, I do not know how to use the array in the rest of my code. I do not think it's possible to create a Sub with a variable name, or run a sub with "ItemAdd" 'watcher' included in a for-loop that runs through the array and creates Sub functions based on the index in the Array or something like that.
Hope anyone can help me. Or knows any other ideas on how to make my idea work.

Answer 1

This doesn't address how you collect or store the various folders, but shows how to manage a collection of "watched" folders with separate "save to" paths.
First, create a class to manage each folder:
Option Explicit
Private OlFldr As Folder
Private SavePath As String
Public WithEvents Items As Outlook.Items
'called to set up the object
Public Sub Init(f As Folder, sPath As String)
Set OlFldr = f
Set Items = f.Items
SavePath = sPath
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
'Just a simple message to show what's going on.
'You can add code here to save the item, or you can pass
' arguments to a common sub defined in a regular module
MsgBox "Mail '" & Item.Subject & "' was added to Folder '" & OlFldr.Name & _
"' and will be saved to '" & SavePath & "'"
End If
End Sub
Here's how you'd use that class to set up your watched folders:
Option Explicit
Dim colFolders As Collection '<< holds the clsFolder objects
Private Sub SetupFolderWatches()
'This could be called on application startup, or from the code which collects
' user selections for folders/paths
Dim Ns As Outlook.NameSpace, inboxParent, arrFolders, f, arr
Set Ns = Application.GetNamespace("MAPI")
Set colFolders = New Collection
Set inboxParent = Ns.GetDefaultFolder(olFolderInbox).Parent
'you'd be reading this info from a file or some other storage...
arrFolders = Array("Test1|C:\Test1_Files\", "Test2|C:\Test2_Files\")
For Each f In arrFolders
arr = Split(f, "|")
colFolders.Add GetFolderObject(inboxParent.Folders(arr(0)), CStr(arr(1)))
Next f
End Sub
'"factory" function to create folder objects
Function GetFolderObject(foldr As Folder, sPath As String)
Dim rv As New clsFolder
rv.Init foldr, sPath
Set GetFolderObject = rv
End Function