一键式文件电子邮件 - 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 查找 Folder，例如：

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

请参考此链接：

如何在Outlook中按名称查找文件夹？

从文件夹路径获取文件夹对象