Loop to set up watches on a selection of Outlook folders

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