一键式文件电子邮件 - Outlook 365

Question

我正在尝试制作一个一键式文件宏，用于查看目录并将电子邮件归档到相应的文件夹中。 我遇到的问题是我必须有针对每个类别的代码，因为文件夹有不同的路径。有没有办法不必将完整路径放入代码中？

见下例

Sub Move_Email()

Dim itm As MailItem
Dim CATNAME As String
Set itm = ActiveExplorer.Selection(1
If itm.Categories = "Customer1" Then
    itm.Move Session.GetDefaultFolder(olFolderInbox).Folders("01 - My Accounts").Folders("Customer1")
Else
    If itm.Categories = "Supplier1" Then
        itm.Move Session.GetDefaultFolder(olFolderInbox).Folders("01 - My Suppliers").Folders("Supplier1")
    Else
    Exit Sub
    End If
 Exit Sub
 End If
 End Sub

我希望它更像

Sub Move_Email2()

Dim itm As MailItem
Dim CATNAME As String
Set itm = ActiveExplorer.Selection(1)
CATNAME = itm.Categories

If itm.Categories = CATNAME Then
    itm.Move Session.GetDefaultFolder(olFolderInbox).Folders(CATNAME)
End If
End Sub

这可能吗？

尝试 1：

Sub Move_Email2()

Dim itm As MailItem
Dim Name As String
Dim FoundFolder As Folder
Set itm = ActiveExplorer.Selection(1)

Name = itm.Categories

If Len(Trim$(Name)) = 0 Then Exit Sub

Set FoundFolder = FindInFolders(Application.Session.Folders, Name)

If Not FoundFolder Is Nothing Then
    itm.Move Session.GetDefaultFolder(olFolderInbox).Folders(FoundFolder.FolderPath)
End If

End Sub

Answer 1

您可以使用 FolderName 来查找文件夹，例如：

Sub Move_Email2()

Dim itm As MailItem
Dim Name As String
Dim FoundFolderPath As String
Dim strFolderPath As Folder
Set itm = ActiveExplorer.Selection(1)

If Len(Trim$(Name)) = 0 Then Exit Sub

For Each Name In itm.Categories
    Set FoundFolder = FindInFolders(Application.Session.Folders, Name)
    If Not FoundFolder Is Nothing Then
        itm.Move GetFolder(FoundFolder.FolderPath)
    End If
Next

End Sub
Function FindInFolders(TheFolders As Outlook.Folders, Name As String)
  Dim SubFolder As Outlook.MAPIFolder

  On Error Resume Next

  Set FindInFolders = Nothing

  For Each SubFolder In TheFolders
    If LCase(SubFolder.Name) Like LCase(Name) Then
      Set FindInFolders = SubFolder
      Exit For
    Else
      Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
      If Not FindInFolders Is Nothing Then Exit For
    End If
  Next
End Function
Function GetFolder(ByVal FolderPath As String) As Outlook.Folder
 Dim TestFolder As Outlook.Folder
 Dim FoldersArray As Variant
 Dim i As Integer

 On Error GoTo GetFolder_Error
 If Left(FolderPath, 2) = "\\" Then
 FolderPath = Right(FolderPath, Len(FolderPath) - 2)
 End If
 'Convert folderpath to array
 FoldersArray = Split(FolderPath, "\")
 Set TestFolder = Application.Session.Folders.item(FoldersArray(0))
 If Not TestFolder Is Nothing Then
 For i = 1 To UBound(FoldersArray, 1)
 Dim SubFolders As Outlook.Folders
 Set SubFolders = TestFolder.Folders
 Set TestFolder = SubFolders.item(FoldersArray(i))
 If TestFolder Is Nothing Then
 Set GetFolder = Nothing
 End If
 Next
 End If
 'Return the TestFolder
 Set GetFolder = TestFolder
 Exit Function

GetFolder_Error:
 Set GetFolder = Nothing
 Exit Function
End Function

请参考此链接：

How To Find Folder By Name In Outlook?

Obtain a Folder Object from a Folder Path