Как я могу скопировать мои электронные письма Outlook (в течение определенного периода времени), чтобы преуспеть?

Question

Новичок в VBA, пытаясь составить список моих электронных писем в Excel с указанным периодом времени. Нашли код для перечисления моих электронных писем, но не можете понять, как ограничить его временем, какие-либо идеи?

Sub GetMail()

Dim OLApp As Object
Dim olFolder As Object
Dim olMailItem As Object

Dim strTo As String
Dim strFrom As String
Dim dateSent As Variant
Dim dateReceived As Variant
Dim strSubject As String
Dim strBody As String

Dim loopControl As Variant
Dim mailCount As Long
Dim totalItems As Long
 '-------------------------------------------------------------
Application.ScreenUpdating = False
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")

Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
Set OLApp = CreateObject("Outlook.Application")
Set olFolder = OLApp.GetNamespace("MAPI").PickFolder
totalItems = olFolder.items.Count
mailCount = 0

For Each loopControl In olFolder.items
     '//If loopControl is a mail item then continue
    If TypeName(loopControl) = "MailItem" Then

        mailCount = mailCount + 1

        Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems

        Set olMailItem = loopControl

        With olMailItem
            strTo = .To

            If Left(strTo, 1) = "=" Then strTo = "'" & strTo
            strFrom = .Sender
            If InStr(1, strFrom, "@") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
            dateSent = .Body
            dateReceived = .ReceivedTime
            strSubject = .Subject
        End With

        With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            .Value = strTo
            .Offset(0, 1).Value = strFrom
            .Offset(0, 2).Value = strSubject

            If InStr(0, strBody, "From:") > 0 Then
                 '//If exists, copy start of email body, up to the position of "From:"
                .Offset(0, 3).Value = Mid(strBody, 1, InStr(1, strBody, "From:") - 1)
            Else
                .Offset(0, 3).Value = strBody
            End If

            .Offset(0, 4).Value = dateSent
            .Offset(0, 5).Value = dateReceived

        End With

        Set olMailItem = Nothing

    End If
Next loopControl

Set olFolder = Nothing
Set OLApp = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"

End Sub

Новичок в VBA, пытаясь составить список моих электронных писем в Excel с указанным периодом времени. Нашли код для перечисления моих электронных писем, но не можете понять, как ограничить его временем, какие-либо идеи?

Answer 1

Попробуйте это. Добавлены 2 переменные даты date1 и date2. Отрегулируйте их в соответствии с вашими требованиями.

Option Explicit

Sub GetMail()

Dim OLApp As Object
Dim olFolder As Object
Dim olMailItem As Object
Dim date1 As Date
Dim date2 As Date
Dim strTo As String
Dim strFrom As String
Dim dateSent As Variant
Dim dateReceived As Variant
Dim strSubject As String
Dim strBody As String

Dim loopControl As Variant
Dim mailCount As Long
Dim totalItems As Long
 '-------------------------------------------------------------
date2 = Now()
date1 = Now() - 3
Application.ScreenUpdating = False
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")

Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
Set OLApp = CreateObject("Outlook.Application")
Set olFolder = OLApp.GetNamespace("MAPI").PickFolder
totalItems = olFolder.Items.Count
mailCount = 0

For Each loopControl In olFolder.Items
     '//If loopControl is a mail item then continue
    If TypeName(loopControl) = "MailItem" Then

        mailCount = mailCount + 1

        Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems

        Set olMailItem = loopControl

        With olMailItem
            strTo = .To

            If Left(strTo, 1) = "=" Then strTo = "'" & strTo
            strFrom = .Sender
            If InStr(1, strFrom, "@") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
            dateSent = .body
            dateReceived = .ReceivedTime
            strSubject = .Subject
        End With

       If dateReceived <= date2 And dateReceived >= date1 Then
        With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            .Value = strTo
            .Offset(0, 1).Value = strFrom
            .Offset(0, 2).Value = strSubject

            If InStr(0, strBody, "From:") > 0 Then
                 '//If exists, copy start of email body, up to the position of "From:"
                .Offset(0, 3).Value = Mid(strBody, 1, InStr(1, strBody, "From:") - 1)
            Else
                .Offset(0, 3).Value = strBody
            End If

            .Offset(0, 4).Value = dateSent
            .Offset(0, 5).Value = dateReceived

        End With
        End If
        Set olMailItem = Nothing

    End If
Next loopControl

Set olFolder = Nothing
Set OLApp = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"

End Sub