我将所有 Outlook 消息组织为对话。我正在寻找一种功能,可以将当前选定的消息从收件箱移动到其各自的文件夹中。
例如,如果我有一个名为“每周状态报告”的电子邮件对话,该对话已归档到“工程”文件夹中,并且我在收件箱中收到回复,我想运行宏并将回复移动到“工程”文件夹。
我在 Microsoft Office Professional Plus 2010 中使用 Outlook。
我最初尝试解决这个问题,但我想:
- 为非 mailitem 对象添加功能;
- 首先检查对话的所有根项是否指向同一张表,然后清理
For Each
循环。如果不是,我想通过对话框提示用户选择所需的文件夹。
这是我目前的尝试:
Sub moveMailToConversationFolder()
Dim olNs As NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim selectedItem As Object
Dim item As Outlook.mailItem ' Mail Item
Dim folder As Outlook.MAPIFolder ' Current Item's Folder
Dim conversation As Outlook.conversation ' Get the conversation
' Dim ItemsTable As Outlook.table ' Conversation table object
Dim mailItem As Object
Dim mailparent As Object
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
' On Error GoTo MsgErr
' // Must Selected Item.
Set selectedItem = Application.ActiveExplorer.Selection.item(1)
' // If Item = a MailItem.
If TypeOf selectedItem Is Outlook.mailItem Then
Set item = selectedItem
Set conversation = item.GetConversation
If Not IsNull(conversation) Then
' Set ItemsTable = conversation.GetTable
' MsgBox conversation.GetRootItems.Count
For Each mailItem In conversation.GetRootItems ' Items in the conversation.
If TypeOf mailItem Is Outlook.mailItem Then
Set folder = mailItem.Parent
item.move GetFolder(folder.FolderPath)
End If
Next
End If
End If
End Sub
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
答案1
这是一个类似的脚本,可能会有帮助。
我的用例有点不同 - 我手动选择自定义视图中的项目,然后从工具栏按钮运行脚本。(我发现对话没有得到正确跟踪,而且有时对话会分散到不同的项目中。)
Option Explicit
Option Base 0
Public Sub MoveToFirstFolder()
Dim oNamespace As Outlook.NameSpace, oSelection As Outlook.Selection
Dim oFolder As Outlook.MAPIFolder
Dim oItem As Object, i As Integer
Set oNamespace = Application.GetNamespace("MAPI")
Set oSelection = oNamespace.Application.ActiveExplorer.Selection
If oSelection.Count < 2 Then Exit Sub
Set oFolder = getFirstNonDefaultFolder(oSelection)
If oFolder Is Nothing Then Exit Sub
' move items
For i = 1 To oSelection.Count
Set oItem = oSelection.Item(i)
If Not oItem.Parent = oFolder Then
oSelection.Item(i).Move oFolder
End If
Next i
End Sub
Private Function getFirstNonDefaultFolder(oSelection As Outlook.Selection) As Outlook.Folder
Dim oItem As Object
Dim oFolder As Outlook.Folder
Dim i As Integer
' get folder
For i = 1 To oSelection.Count
Set oFolder = oSelection.Item(i).Parent
Debug.Print ">" & oFolder.FullFolderPath
If Not isDefaultFolder(oFolder) Then
Set getFirstNonDefaultFolder = oFolder
Exit Function
End If
Next i
End Function
Private Function isDefaultFolder(oFolder As Outlook.Folder) As Boolean
Dim oNamespace As Outlook.NameSpace
Dim defaultFolders, fldrNum
isDefaultFolder = False
defaultFolders = Array( _
olFolderInbox, olFolderSentMail, _
olFolderDrafts, _
olFolderDeletedItems, olFolderJunk, _
olFolderOutbox, _
olFolderCalendar, _
olFolderContacts, olFolderSuggestedContacts, _
olFolderNotes, _
olFolderTasks, olFolderToDo, _
olFolderJournal, _
olFolderConflicts, olFolderLocalFailures, olFolderServerFailures, olFolderSyncIssues, _
olFolderManagedEmail, olPublicFoldersAllPublicFolders _
)
Set oNamespace = Application.GetNamespace("MAPI")
On Error Resume Next ' Non-existant DefaultFolders cause errors
For Each fldrNum In defaultFolders
If oFolder = oNamespace.GetDefaultFolder(fldrNum) Then
If Err.Number Then
Err.Clear
Else
isDefaultFolder = True
Exit Function
End If
End If
Next fldrNum
End Function