Question

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

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

如何将Outlook电子邮件（在特定时间段内）复制为Excel？

1 个答案: