Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос VBA: Перемещение письма в папку, где лежит предшественник (MS Outlook), начал писать и столкнулся, с нехваткой знания VBA и объектной модели Outlook
 
Доброго дня, друзья!

не нашел на нашем форуме ветки для других продуктов 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
Изменено: BUGL - 19 Мар 2018 17:44:31
Нет ТЗ - получишь ХЗ.
Люблю универсально-стандартные решения, даже если они сложнее
 
понимаю, что не профильный форум. но неужели тут нет ни одного знающего outlook человека? или проблема в другом? п
ладно, буду сюда писать, что нашел.
http://www.sql.ru/forum/1226646/outlook-sortirovka-pochty-vba
очень похожая задача. буду капать.
Нет ТЗ - получишь ХЗ.
Люблю универсально-стандартные решения, даже если они сложнее
Страницы: 1
Читают тему (гостей: 1)
Наверх