0

VBA 新手，尝试在特定时间段内以 Excel 格式列出我的 Outlook 电子邮件。找到列出我的电子邮件的代码，但不知道如何将其限制在一个时间段内，有什么想法吗？

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 格式列出我的 Outlook 电子邮件。找到列出我的电子邮件的代码，但不知道如何将其限制在一个时间段内，有什么想法吗？

4

1 回答 1

0

尝试这个。添加了 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
于 2019-03-21T03:04:37.640 回答