循环以在选定的Outlook文件夹上设置监视

我在Outlook中的VBA中执行以下操作 . 将Outlook项目拖动到指定的文件夹后，我将此Outlook项目保存到我的计算机（即文件系统） .

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

如果用户将文件添加到在顶部声明的变量Items / Items2中指定的目录，则此代码将Outlook项目保存到目录sPath（Sub Items / Items2_AddItem）中的计算机 .

问题是它需要我在VBA中手动添加VBA在添加项目时应该“监视”的文件夹以及保存这些文件的位置 . 因此，它需要为我拥有的每个文件夹编写一个新的Items变量和新的Items_ItemAdd子 .

我想做以下事情：

• 通过Outlook中的用户界面而不是VBA，为添加的项目选择应该为"watched"的文件夹，以及应该将其保存到的文件夹 . 用户应该选择多个文件夹（我不在乎他们是否必须一次选择一个），计算机上有多个保存文件夹 .

• 我希望Outlook记住用户在关闭Outlook时所做的选择 .

为了使用户更友好，我想到了以下内容 .

• 用户在Outlook中选择文件夹 . 我发现的代码执行此操作：

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

• 用户然后选择该项目应保存在计算机上的文件夹 . 我发现的代码允许您将变量设置为输入文件路径：

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

我希望上面的代码在用户按下我的宏将设置的功能区中的按钮时运行 .

我希望Outlook能够观看用户选择的这些文件夹（即Sub Items_ItemAdd的功能） . 这是我被卡住的地方 . 我想要在Outlook关闭后记住用户的选择（即用户每次打开Outlook时都不必选择他的文件夹） .

现在我的问题如下：

• 我想象一种使这项工作的方法是每次用户选择文件夹和保存文件夹时，在VBA代码中直接创建一个新变量Items（i）和一个新的Sub Items（i）_ItemAdd . 但是，我在Outlook中看到这是不可能的，与Excel不同 . 这是真的？如果没有：如何在Outlook中使用VBA创建VBA代码？

• 我能想象的另一种方式如下 . 我将用户输入的内容保存到文本文件中，然后从文本文件中读取并将其保存到数组中 . 但是，我不知道如何在我的其余代码中使用该数组 . 我认为不可能创建一个带有变量名的Sub，或者运行一个带有“ItemAdd”'sub的子包含在运行数组的for循环中并根据Array中的索引创建Sub函数像那样 .

希望有人能帮助我 . 或者知道如何让我的想法发挥作用的任何其他想法 .