Я организую все свои сообщения Outlook как разговоры. Я ищу функцию для перемещения текущих выбранных сообщений из папки «Входящие» в соответствующие папки.
Например, если у меня есть разговор по электронной почте под названием "Еженедельный отчет о состоянии", который был сохранен в папке "Engineering", и я получаю ответ в своей папке входящих сообщений, я хотел бы запустить макрос и переместить ответ в «». Инженерная »папка.
Я использую Outlook в Microsoft Office Professional Plus 2010.
Моя первоначальная попытка решить проблему вроде работает, но я бы хотел:
- Добавить функциональность для объектов не-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