Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Экспорт данных из INBOX & SENT папок Outlook
 
Всех приветствую.

Прошу помощи клуба знатоков.
Руководством поставлена задача иметь отчет по работе с generic e-mail. Я имею ввиду, некая Excel таблица в которой присутствует информация из INBOX & SENT папок:  сколько писем приходит (папка INBOX),  когда, от кого, тема и на сколько писем был ответ (папка SENT) от сотрудника, в обязанности которого входит работа с generic e-mail. В MS Outlook присутствует несколько учетных записей.

По создал макрос на основе приложенного уважаемым Webley, но к сожалению выгружается какая то часть и возникает ошибка “Run-Time Error (13), Type Mismatch”. К сожалению знаний не хватает, поэтому прошу помощь зала.
 
Если таки часть выгружается, значит проблему надо выуживать у вас. но в целом идея провальная, ибо она однозначно блокирует возможность иметь подпапки, а также нужно наверно отчет за период, а не за всю историю работы outlook.
По вопросам из тем форума, личку не читаю.
 
.Цитата - не бездумная копия. Для простого ответа есть кнопка Ответить [МОДЕРАТОР]

Уважаемый БМВ.
1. Выгружается только часть насколько я понимаю из-за ошибки. Если Вы знаете как ее исправить - прошу совет в студию. Пример в приложении.
2. Не понятно почему Вы решили идея провальная? Подпапки иметь можно и экспортировать можно, но в этом нет необходимости. Интересует только папка INBOX & SENT
2.Если есть возможность определить период для экспорта - будет замечательно, нет - обойдемся.

Спасибо за понимание.

Алексей.
 
Ну ошибку я воспроизвел. природа пока не понятна, но больше похоже на то что аутлук не успевает отработать,  изменил код вот так


Код
        r = 1
        On Error GoTo err:
        For Each myItem In myMail

                Cells(r + 1, 1) = myItem.ReceivedTime
                Cells(r + 1, 2) = myItem.SenderName
                Cells(r + 1, 3) = myItem.SenderEmailAddress
                Cells(r + 1, 4) = myItem.Subject
                Cells(r + 1, 5) = myItem.Categories
            r = r + 1

        Next
        Exit Sub
err:
    If err.Number = 13 Then
    For i = 1 To 10000
    Next
    Resume
    Else
        Stop
    End If
End Sub
По вопросам из тем форума, личку не читаю.
 
Хм... хитро :) Огромное спасибо БМВ !

Еще пара вопросов:

1. Цикл до 10000. Насколько это важно? Уменьшил ради эксперимента до 1000 - полет нормальный, меньше уже ошибка повторяется :)
2. И все таки есть возможность определить период дат для экспорта писем или это невозможно?
3. Если автоматически при запуске файла, запускать макросы, как думаете, нормально будут работать или есть противопоказания ?

Еще раз спасибо за помощь

Алексей.
 
1 . 10000 может зависеть от ПК. Это просто пауза. Можно через таймер крутануть типа через секунду далее идти

Код
err:
    If err.Number = 13 Then
    t = Timer
    Do While Timer - t < 1
    Loop
    Resume
    Else
        Stop
    End If
End Sub


2. возможно только нужно фильтр настроить
https://stackoverflow.com/questions/55924883/how-to-filter-an-outlook-view-in-vba-based-on-to-email-addresses

3. опять же, если правильно сделать, то противопоказаний нет.
Изменено: БМВ - 24 сен 2020 22:24:21
По вопросам из тем форума, личку не читаю.
 
Доброе время суток
Цитата
a.m.v. написал:
определить период дат
Как вариант
Код
Public Sub Test()
    Dim outApp As New Outlook.Application
    Dim nSpace As Outlook.Namespace
    Dim pFolder As Outlook.Folder
    Dim pItems As Outlook.Items
    Dim pMail As MailItem
    
    Set nSpace = outApp.GetNamespace("MAPI")
    Set pFolder = nSpace.Folders("vasya.pupkin@hp.com")
    Set pFolder = pFolder.Folders("Sent")
    Set pItems = pFolder.Items
    Set pMail = pItems.Find("[SentOn] > '09.09.2020' And [SentOn] < '12.09.2020'")
    Do Until pMail Is Nothing
        Debug.Print pMail.Subject & " = " & pMail.SentOn
        Set pMail = pItems.FindNext
    Loop
End Sub

P. S. формат даты языково зависимый.
 
Андрей VG, спасибо за вариант !

Стесняюсь спросить, как мне использовать этот блок для сбора информации ?
Код
Cells(1, 1) = "Data"
        Cells(1, 1) = "Creation Time"
        Cells(1, 2) = "To"
        Cells(1, 3) = "Subject"
        Cells(1, 4) = "Status"

        r = 1
        On Error GoTo Err:
        For Each myItem In myMail
 
                Cells(r + 1, 1) = myItem.CreationTime
                Cells(r + 1, 2) = myItem.Recipients
                Cells(r + 1, 4) = myItem.Subject
                Cells(r + 1, 5) = myItem.Categories
            r = r + 1

Цитата
БМВ написал: 1 . 10000 может зависеть от ПК. Это просто пауза. Можно через таймер крутануть типа через секунду далее идти
Еще раз спасибо БМВ  ;)
Попробую, посмотрю что получится и тему по ссылку изучу.
 
Уважаемый Андрей VG.

Попытался протестировать Ваш код, к сожалению реакции никакой. Дату прописал в формате дат используемый на ноуте.
 
Цитата
a.m.v. написал:
реакции никакой
В панели Immediate редактора VBA ничего нет? Папка Folders("Sent")? Если поставить точку останова кода на Do Until pMail Is Nothing, то pMail Is Nothing?
Вы уверены, что это я должен из вас информацию вытягивать?
 
Уважаемый Андрей VG.
Абсолютно уверен, что нет. Если имел достаточно знаний, знал бы какую информацию предоставить.

В Immediate вижу 4 блока повторяющихся записей.
RE: ??????????? ?????? = 09/24/2020 2:19:51 PM
RE: ??????????? ?????? = 09/24/2020 2:23:05 PM
RE: ?????? = 09/24/2020 2:37:45 PM

Цитата
Андрей VG написал: Если поставить точку останова кода на Do Until pMail Is Nothing, то pMail Is Nothing?
Вот здесь к сожалению не понял, куда конкретно поставить нужно :(
 
Цитата
a.m.v. написал:
в формате дат используемый на ноуте
Цитата
a.m.v. написал:
09/24/2020 2:19:51 PM
на ноуте в таком же формате даты прописаны? Тоже через слеш и в порядке ММ/ДД/ГГГГ?
Кстати, если писем может быть много, то лучше использовать отбор через SQL. Здесь приводил пример кода такого отбора: Как можно ускорить обработку писем из почты?
Изменено: Дмитрий(The_Prist) Щербаков - 25 сен 2020 11:19:34
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий(The_Prist) Щербаков Спасибо!

Мой косяк. Изменил . на / Но обязательно ли добавлять время?

В Immidiate появилось разнобразие :) (куча строк с подобной информацией)

RE: ??? ???? ??????? | ????????? ??????? ????????. = 09/01/2020 9:02:37 AM
RE: ??? ???? ??????? | ????????? ??????? ????????. = 09/01/2020 9:04:55 AM
RE: ????????? ??? VDI ?????? ???? -#?????? 5445686/1 = 09/01/2020 9:05:17 AM
...

Но на листе информация отсутствуют. Что я упустил?
Изменено: a.m.v. - 25 сен 2020 12:32:13
 
Цитата
a.m.v. написал:
Но на листе информация отсутствуют.
а где полный код, который у Вас получился? Там вообще вывод на лист есть?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Использовал код, предоставленный Андрей VG. Спасибо ему еще раз. В коде вывода нет, прилагаю.

Код
Public Sub Test()
    Dim outApp As New Outlook.Application
    Dim nSpace As Outlook.Namespace
    Dim pFolder As Outlook.Folder
    Dim pItems As Outlook.Items
    Dim pMail As MailItem
     
    Set nSpace = outApp.GetNamespace("MAPI")
    Set pFolder = nSpace.Folders("vasya.pupkin@hp.com")
    Set pFolder = pFolder.Folders("Sent")
    Set pItems = pFolder.Items
    Set pMail = pItems.Find("[SentOn] > '09.09.2020' And [SentOn] < '12.09.2020'")
    Do Until pMail Is Nothing
        Debug.Print pMail.Subject & " = " & pMail.SentOn
        Set pMail = pItems.FindNext
    Loop
End Sub


Пытался добавить вывод сам по дате отправке , получателю, тема, категории блоком из предыдущего кода но не получилось.

Код
Set nSpace = outApp.GetNamespace("MAPI")
    Set pFolder = nSpace.Folders("vasya.pupkin@hp.com")
    Set pFolder = pFolder.Folders("Sent Items")

        Cells(1, 1) = "Data"
        Cells(1, 2) = "To"
        Cells(1, 3) = "Subject"
        Cells(1, 4) = "Status"
 
        r = 1
        On Error GoTo Err:
        For Each pItem In pMail
  
                Cells(r + 1, 1) = myItem.CreationTime
                Cells(r + 1, 2) = myItem.Recipients
                Cells(r + 1, 3) = myItem.Subject
                Cells(r + 1, 4) = myItem.Categories
            r = r + 1
 
        Next
        Exit Sub
Изменено: a.m.v. - 25 сен 2020 12:51:37
 
А где строки-то потеряли?
Цитата
a.m.v. написал:
Set pItems = pFolder.Items
Set pMail = pItems.Find("[SentOn] > '09.09.2020' And [SentOn] < '12.09.2020'")
без них получается, что pMail у Вас пуст и ни смотреть ни записывать нечего...
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий,

видимо я не умею правильно обьяснять, особенно когда сам не догоняю. Привожу тот код который пытался использовать для решения задачи.

В результате в Immediate только одна запись.

RE: ??? ???? ??????? | ????????? ??????? ????????. = 09/01/2020 9:02:37 AM
Код
Public Sub Test()
    Dim outApp As New Outlook.Application
    Dim nSpace As Outlook.Namespace
    Dim pFolder As Outlook.Folder
    Dim pItems As Outlook.Items
    Dim pMail As MailItem
     
    Set nSpace = outApp.GetNamespace("MAPI")
    Set pFolder = nSpace.Folders("vasya.pupkin@hp.com")
    Set pFolder = pFolder.Folders("Sent Items")
    Set pItems = pFolder.Items
    Set pMail = pItems.Find("[SentOn] > '09/01/2020' And [SentOn] < '09/24/2020'")
    Do Until pMail Is Nothing
        Debug.Print pMail.Subject & " = " & pMail.SentOn
        Set pMail = pItems.FindNext
        
        Cells(1, 1) = "Data"
        Cells(1, 2) = "To"
        Cells(1, 3) = "Subject"
        Cells(1, 4) = "Status"
  
        r = 1
        On Error GoTo err:
        For Each pItem In pMail
   
                Cells(r + 1, 1) = myItem.CreationTime
                Cells(r + 1, 2) = myItem.Recipients
                Cells(r + 1, 3) = myItem.Subject
                Cells(r + 1, 4) = myItem.Categories
            r = r + 1
  
        Next
        Exit Sub
err:
    If err.Number = 13 Then
    t = Timer
    Do While Timer - t < 1
    Loop
    Resume
    Else
        Stop
    End If
Loop
End Sub
Изменено: a.m.v. - 25 сен 2020 14:16:24
 
тут как бы...Я бы все равно использовал свой метод(через SQL), а не этот.
Код
Public Sub Test()
    Dim myOlApp As Object 'New Outlook.Application
    Dim objNamespace As Object 'Outlook.Namespace
    Dim objFolder As Object 'Outlook.MAPIFolder
    Dim filteredItems As Object 'Outlook.Items
    Dim itm As Object
    Dim strFilter As String
    Dim r As Long, ir As Long
    Dim aRec, aRes
  
    Set myOlApp = CreateObject("Outlook.Application")
    Set objNamespace = myOlApp.GetNamespace("MAPI")
    Set objFolder = objNamespace.Folders("vasya.pupkin@hp.com").Folders("Sent Items")
  
    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & Chr(34) & " >= '" & Format(DateSerial(2020, 9, 1), "dd/MM/YYYY") & "' AND " & _
                          Chr(34) & "urn:schemas:httpmail:datereceived" & Chr(34) & " <= '" & Format(DateSerial(2020, 9, 24), "dd/MM/YYYY") & "'"
  
    Set filteredItems = objFolder.Items.Restrict(strFilter)
    If filteredItems.Count = 0 Then
        Debug.Print "Не найдено писем по заданным условиям"
    Else
        r = 1
        ReDim aRes(1 To filteredItems.Count, 1 To 4)
        For Each itm In filteredItems
            aRes(r, 1) = itm.CreationTime
            ReDim aRec(1 To itm.Recipients.Count)
            For ir = 1 To itm.Recipients.Count
                aRec(ir) = itm.Recipients(ir)
            Next
            aRes(r, 2) = Join(aRec, "; ")
            aRes(r, 3) = itm.Subject
            aRes(r, 4) = itm.Categories
            r = r + 1
        Next
        Cells(2, 1).Resize(filteredItems.Count, 4).Value = aRes
    End If
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Дмитрий !!! С П А С И Б О !!!

Заработало :) Еще пара вопросов, если не возражаете.

1. Для того чтобы присутствовали заголовки данных каким образом лучще прописать в этом случае?
2. В случае использования SQL, нужно создавать дополнительный фильтр, если я правильно понимаю. Сейчас выгружаются данные за весь период. Как лучше прикрутить ибо и SQL для меня пока далеко.
3. А каким образом возможно добавить Recipients Emails?

Изменено: a.m.v. - 25 сен 2020 17:09:49
 
1. Что такое заголовки и где они должны присутствовать? О чем мы сейчас? Если о листе, то ровно так же, как делали изначально.
Код
Cells(1, 1) = "Data"
        Cells(1, 2) = "To"
        Cells(1, 3) = "Subject"
        Cells(1, 4) = "Status"
2. Тоже не понял. Какой дополнительный - он там один. Период Вы сами задаете, там ведь прописано: Format(DateSerial(2020, 9, 1), "dd/MM/YYYY"). Почитайте справку про DateSerial. Или подпихивайте корректную дату иным способом.
3. Видимо, надо Вам начать изучать объектную модель Outlook и пробовать, пробовать, пробовать...
Код
            ReDim aRec(1 To itm.Recipients.Count)
            For ir = 1 To itm.Recipients.Count
                aRec(ir) = itm.Recipients(ir) & "(" & itm.Recipients(ir).Address & ")"
            Next
            aRes(r, 2) = Join(aRec, "; ")
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Страницы: 1
Читают тему (гостей: 1)
Наверх