Выгрузка писем из Outlook в Excel

[mrSparkle]

Всем добрый день.
Необходимо выгружать письма из почты в 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

[Eugene-LS]

Сообщение от 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