Доброго дня, друзья!
не нашел на нашем форуме ветки для других продуктов MS.
Пытаюсь написать макрос, который поможет сортировать входящие письма в Outlook 2010.
Задача:
Когда выделяешь письмо нужно по теме письма определять папку, где есть последнее письмо всей цепочки писем (цепочка - тема).
На панели должна быть кнопка, которая меняет свое название на "Переместить в ПАПКА". На кнопке должна подставляться определившаяся папка для выделенного письма.
По кнопке при нажатии переместить письмо в определившуюся папку.
Если выделено несколько писем: выдавать ошибку.
Если цепочки не найдено, то при нажатии на кнопку просить определить папку.
Я вывел кнопку со ссылкой на макрос через Настройку панели.
Начал писать и столкнулся, с нехваткой знания VBA и объектной модели Outlook.
Буду очень благодарен за любую помощь, даже маленькую, даже частичную: просто обращение к объектам или проверки тоже будут помогать.
Сделал скелет программы и ищу по крупицам информацию в нете.
Все недостающие части выделены в виде комментариев с логикой.
| Код |
|---|
Все недостающие части выделены в виде комментариев с логикой.
Sub SortMail()
'ждем выделение 1 письма
On Error GoTo 0 'Resume Next
Dim FolderName As String - конечная в иерархии папка FolderAdress
Dim FolderAdress As String - полный путь до папки
'если выделено несколько писем: если начало работы по выделению - ничего не делать. если начало работы по нажатию - выдать ошибку.
'иначе
'FolderAdress = Find_the_folder()
'если FolderAdress не найдено, то FolderNamе = "?"
'иначе FolderNamе = конечная в иерархии папка FolderAdress.
'конец если
'поменять имя кнопки Макроса на панели инструментов на "MoveTo FolderNamе". если FolderName не задано, то ставить "?"
'тут ждем клик на кнопку Макроса
'если FolderAdress не найдено, то
'выдать диалог со списком всех папок Inbox включая вложенные для выбора папки. OK и отмена.
'записать в FolderAdress
'конец если
'FolderNamе = конечная в иерархии папка FolderAdress.
Call MoveIt2Folder(FolderName)
End Sub
==========================================
Sub MoveIt2Folder(FolderName As String)
'если папка находится на втором уровне вложенности и далее - то надо заходить в нужные подпапки.
On Error GoTo 0 'Resume Next
Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
On Error Resume Next
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Folders(FolderName)
On Error GoTo 0 'Resume Next
If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If
If Application.ActiveExplorer.Selection.Count = 0 Then
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move objFolder
End If
End If
Next
' записать лог в файл на диске C: txt в виде Дата+Время письма; Отправитель; Тема перенос в папку Х
Set objItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub
==========================================
Function Find_the_folder()
'On Error Resume Next 'GoTo 0
Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Set objNamespace = myOlApp.GetNamespace("MAPI")
Dim strFilter As String
Dim itm As Object
Dim SubjectOu As String
' ТЕМА = тема выделенного письма
' ПАПКА = папка, где лежит нужное письмо
'найти самое последнее по времени получения письмо во всей папке Inbox с учетом поиска во вложенных папках, где тема like ТЕМА
Set itm = myOlApp.ActiveExplorer()
SubjectOu = "ТЕМА" 'ТЕМА
strFilter = "urn:schemas:httpmail:subject like" & "'" & "%" & SubjectOu & "%" & "'"
SearchSubFolders = True
Scope = "'Inbox'"
Set Search = myOlApp.AdvancedSearch(Scope, strFilter, SearchSubFolders)
Set filteredItems = Search.Results
' тут пытался найти самое последнее по времени получения письмо во всей папке Inbox с учетом поиска во вложенных папках
' не хватает понимания и знания объектов и VBA
For Each itm In filteredItems
Debug.Print itm.Subject
Debug.Print itm.SenderName
Debug.Print itm.SentOn
Next
Set myOlApp = Nothing
'определить полный путь папки с где она лежит
'вернуть ПАПКА
End Function
|
