指定日期范围从旧到新导入Outlook邮件至Excel的VBA宏问题求助

问题根因 #

循环提前退出原因 #

Outlook文件夹默认按「新邮件在前、旧邮件在后」排序，你遍历到的第一封邮件就是最新收到的，远大于你设置的2020年结束日期，直接触发了Else: Exit For逻辑，导致循环直接终止。

Sort方法报错原因 #

你犯了两个低级错误：

1. 用了未声明也未赋值的变量OutlookItems，它根本没有指向任何实际的邮件集合，自然报「需要对象」错误
2. Sort方法的第一个参数是字符串格式的属性名，需要用双引号包裹，不能用方括号

修复后可直接运行的代码 #

Sub Download_Emails()
    Application.ScreenUpdating = False

    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Namespace
    Dim Folder As MAPIFolder
    Dim OutlookMail As Variant
    Dim objOwner As Outlook.Recipient
    Dim i As Integer
    Dim olItems As Outlook.Items ' 明确声明为Outlook Items类型
    Dim LastRow As Long
    Dim ToDt As Date
    Dim FromDt As Date ' 提前提取单元格值，避免循环内反复读取

    ' 提前读取日期参数
    FromDt = Range("L1").Value
    ToDt = Range("L2").Value + 1
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    i = LastRow

    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set objOwner = OutlookNamespace.CreateRecipient("xxxxxxxxxx.com") ' 替换为你的邮箱地址
    objOwner.Resolve

    If objOwner.Resolved Then
        Set Folder = OutlookNamespace.PickFolder ' 简化原有冗余代码
    End If

    ' ------------ 新增排序逻辑 ------------
    Set olItems = Folder.Items
    olItems.Sort "ReceivedTime", True ' True为升序，即强制从旧到新排列
    ' -------------------------------------

    For Each OutlookMail In olItems
        If TypeName(OutlookMail) = "MailItem" Then
            Dim recvTime As Date
            recvTime = CDate(OutlookMail.ReceivedTime)
            
            If recvTime < FromDt Then
                ' 早于起始日期，跳过
            ElseIf recvTime < ToDt Then
                ' 符合日期范围，写入表格
                Range("A" & i + 1) = OutlookMail.Subject
                Range("B" & i + 1) = OutlookMail.ReceivedTime
                Range("C" & i + 1) = OutlookMail.SenderName
                ' Range("D" & i + 1) = OutlookMail.Body ' 需要导入正文可取消注释
                i = i + 1
            Else
                ' 已经按从旧到新排序，后续邮件日期都更大，直接退出
                Exit For
            End If
        End If
    Next OutlookMail
 
    ' 释放对象
    Set olItems = Nothing
    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
 
    Sheet1.Cells.WrapText = False
    Application.ScreenUpdating = True
    MsgBox "邮件导入完成！", vbOKOnly + vbInformation
End Sub

内容的提问来源于stack exchange，提问作者Seema