Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 07.11.2023, 12:00   #1
mrSparkle
Новичок
Джуниор
 
Регистрация: 07.11.2023
Сообщений: 1
По умолчанию Выгрузка писем из Outlook в Excel

Всем добрый день.
Необходимо выгружать письма из почты в excel, учитывая отправителя и период времени.
Подошел следующим образом. Таблица excel, в А1 указываем почту, в В1 дату с которой начать поиск, в С1 дату на которой поиск заканчивается. При работе макроса создается новый лист в котором должны отображаться адрес отправителя и текст самого письма. Вот на датах я и завис. Ругается в следующей строке If OutlookMail.ReceivedTime >= StartDate And OutlookMail.ReceivedTime <= EndDate And OutlookMail.SenderEmailAddress = EmailAddress Then Подскажите что нужно изменить в коде?
Код:
Sub ВыгрузкаПисем()
    Dim OutlookApp As Object
    Dim OutlookNamespace As Object
    Dim Folder As Object
    Dim OutlookMail As Object
    Dim ws As Worksheet
    Dim EmailAddress As String
    Dim StartDate As Date
    Dim EndDate As Date
    Dim i As Integer
    
    ' Получаем данные из ячеек
    EmailAddress = Sheets("Лист1").Range("A1").Value
    StartDate = Sheets("Лист1").Range("B1").Value
    EndDate = Sheets("Лист1").Range("C1").Value
    
    ' Создаем новый лист
    Set ws = ThisWorkbook.Sheets.Add(After:= _
             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "ВыгрузкаПисем"
    
    ' Инициализируем объекты Outlook
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' Получаем папку "Входящие" в Outlook
    Set Folder = OutlookNamespace.GetDefaultFolder(6)
    
    ' Проводим по всем письмам и выгружаем их на новый лист
    i = 1
    For Each OutlookMail In Folder.Items
        If OutlookMail.ReceivedTime >= StartDate And OutlookMail.ReceivedTime <= EndDate And OutlookMail.SenderEmailAddress = EmailAddress Then
            ws.Cells(i, 1).Value = OutlookMail.SenderEmailAddress
            ws.Cells(i, 2).Value = OutlookMail.Body
            i = i + 1
        End If
    Next OutlookMail
    
    ' Освобождаем ресурсы Outlook
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
    
End Sub
mrSparkle вне форума Ответить с цитированием
Старый 25.11.2023, 10:05   #2
Eugene-LS
Пользователь
 
Аватар для Eugene-LS
 
Регистрация: 23.02.2018
Сообщений: 75
По умолчанию

Цитата:
Сообщение от mrSparkle Посмотреть сообщение
Подскажите что нужно изменить в коде?
Раз вы работаете со полной датой - временем (.ReceivedTime) это следует учитывать - поэтому для сравнения лучше указывать полный формат (dd.mm.yyyy hh:nn:ss).
Примерно так:
Код:
Sub ВыгрузкаПисем()
' ЗАГРУЗКА на лист данных писем из MS Outlook по диапазону дат и адресу отправителя
' -------------------------------------------------------------------------------------------------/
    Dim OutlookApp As Object
    Dim OutlookNamespace As Object
    Dim Folder As Object
    Dim OutlookMail As Object
    Dim ws As Worksheet
    Dim EmailAddress As String
    Dim StartDate As Date, EndDate As Date
    Dim iVal As Integer, vVal
' -------------------------------------------------------------------------------------------------/
On Error GoTo ВыгрузкаПисем_Err

' Получаем данные из ячеек:
    vVal = Sheets("Лист1").Range("A1").Value & ""
    If Len(vVal) < 3 Then
        MsgBox "Не указан адрес отправителя!", vbExclamation
        ThisWorkbook.Sheets("Лист1").Range("A1").Select
        Exit Sub
    End If
    EmailAddress = vVal

'Дата начала:
    vVal = Sheets("Лист1").Range("B1").Value
    If IsDate(vVal) = False Then vVal = CDate(1)       ' 1 = 31.12.1899
    StartDate = DateValue(vVal) ' Дата без (возможного) времени
    
'Дата окончания:
    vVal = Sheets("Лист1").Range("C1").Value
     If IsDate(vVal) = False Then vVal = CDate(999999) ' 999999 = 4637-й год!
    EndDate = DateValue(vVal) + TimeValue("23:59:59") 'Дата без времени + время на конец суток
    
    'Debug.Print "StartDate: "; StartDate; " - EndDate: "; EndDate
    'GoTo ВыгрузкаПисем_End
    
' Удаляем старый лист (если есть)
    TWB_SheetDelete "ВыгрузкаПисем" 'Удаление листа по аргументу названия без запроса на подтверждение
    
' Создаем новый лист
    
    Set ws = ThisWorkbook.Sheets.Add(After:= _
             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "ВыгрузкаПисем"
    
' Инициализируем объекты Outlook
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' Получаем папку "Входящие" в Outlook
    Set Folder = OutlookNamespace.GetDefaultFolder(6)
    
    ' Проводим по всем письмам и выгружаем их на новый лист
    iVal = 1
    For Each OutlookMail In Folder.Items
        'Debug.Print OutlookMail.SenderEmailAddress; ; OutlookMail.ReceivedTime
        If OutlookMail.ReceivedTime >= StartDate _
                    And OutlookMail.ReceivedTime <= EndDate _
                    And OutlookMail.SenderEmailAddress = EmailAddress Then
            ws.Cells(iVal, 1).Value = OutlookMail.SenderEmailAddress
            ws.Cells(iVal, 2).Value = OutlookMail.Body
            iVal = iVal + 1
        End If
    Next OutlookMail

' -------------------------------------------------------------------------------------------------/
ВыгрузкаПисем_End:
    On Error Resume Next
    ' Освобождаем ресурсы Outlook
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
    Err.Clear
    Exit Sub

ВыгрузкаПисем_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub : ВыгрузкаПисем.", vbCritical, "Error!"
    'Debug.Print "ВыгрузкаПисем_Line: " & Erl & "."
    Err.Clear
    Resume ВыгрузкаПисем_End
End Sub

Private Sub TWB_SheetDelete(sWSName$)
'Удаление листа по аргументу названия без запроса на подтверждение
Dim ws As Worksheet
Dim blnAlerts As Boolean
    blnAlerts = Application.DisplayAlerts ' Запоминаем  как было
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = sWSName Then ws.Delete
    Next
    Application.DisplayAlerts = blnAlerts ' Восстанавливаем как было
    Set ws = Nothing
End Sub

Последний раз редактировалось Eugene-LS; 25.11.2023 в 10:11.
Eugene-LS вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
обработка входящих писем в Outlook и запуск макроса Excel unbanned Microsoft Office Excel 0 27.03.2019 23:46
Отправка писем в Outlook'e Parklane1488 Microsoft Office Excel 9 25.08.2014 16:46
перебор писем в OutLook'e mad_max.86@gmail.r Microsoft Office Access 7 12.05.2012 22:44
Интересный макрос для создания писем в Outlook через Excel Neo007 Microsoft Office Excel 17 19.04.2009 20:44
MS Excel и MS Outlook (2003) отсылка писем IceB Microsoft Office Excel 1 02.07.2007 13:32