为何获取今日邮件数量返回0？Outlook宏代码排查求助

嘿，我猜你肯定是踩了日期比较的逻辑坑！你想啊，Outlook里邮件的ReceivedTime是带时分秒的完整日期时间（比如2024/5/20 14:30:00），但你Excel单元格里的“今日”对应的是2024/5/20 00:00:00，直接用等于号判断的话，只有凌晨0点整收到的邮件才会被统计到，当然会漏掉大部分今日邮件啦！

下面给你拆解问题，再附上修复后的完整代码：

核心修复点：日期比较要忽略时间 #

别直接用Email.ReceivedTime = TargetDate，改成提取两者的纯日期部分对比，用DateValue(Email.ReceivedTime) = DateValue(TargetDate)，这样不管邮件是今天几点收到的，只要日期匹配就能被统计到。

顺便优化下循环和文件夹获取逻辑 #

• 遍历邮箱的时候，要是涉及共享邮箱，得用GetSharedDefaultFolder而不是直接找文件夹，不然会找不到目标邮箱；
• 你的Do Until循环要注意终止条件，别不小心搞成无限循环或者提前退出。

修复后的完整代码示例 #

Sub HowManyDatedEmails()
    Dim objOutlook As Object, objnSpace As Object, objFolder As Object
    Dim EmailItem As Object
    Dim ws As Worksheet
    Dim i As Integer, dateRow As Integer
    Dim targetEmail As String, targetDate As Date
    Dim emailCount As Integer
    
    ' 初始化Outlook和工作表对象
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")
    Set ws = ThisWorkbook.Worksheets("Sheet1") ' 记得改成你的工作表名称
    
    ' 遍历B3到B6的邮箱地址
    For i = 3 To 6
        targetEmail = ws.Cells(i, "B").Value
        emailCount = 0
        
        ' 获取目标邮箱的收件箱（普通邮箱用下面这句，共享邮箱看注释）
        On Error Resume Next ' 防止邮箱不存在报错
        Set objFolder = objnSpace.Folders(targetEmail).Folders("收件箱")
        ' 如果是共享邮箱，替换成下面这段：
        ' Dim sharedRecip As Object
        ' Set sharedRecip = objnSpace.CreateRecipient(targetEmail)
        ' Set objFolder = objnSpace.GetSharedDefaultFolder(sharedRecip, olFolderInbox)
        On Error GoTo 0
        
        If Not objFolder Is Nothing Then
            ' 遍历C3到C6的日期（Do Until循环实现）
            dateRow = 3
            Do Until dateRow > 6
                targetDate = ws.Cells(dateRow, "C").Value
                emailCount = 0 ' 每次统计新日期前重置计数
                
                ' 给邮件按时间排序，提升统计效率
                objFolder.Items.Sort "[ReceivedTime]", olDescending
                
                ' 遍历文件夹里的所有邮件
                For Each EmailItem In objFolder.Items
                    ' 只统计邮件类项，且日期匹配（忽略时间）
                    If EmailItem.Class = olMail And DateValue(EmailItem.ReceivedTime) = DateValue(targetDate) Then
                        emailCount = emailCount + 1
                    End If
                Next EmailItem
                
                ' 把统计结果写入D列对应行（你可以改成自己需要的位置）
                ws.Cells(i, "D").Value = emailCount
                dateRow = dateRow + 1
            Loop
        Else
            ws.Cells(i, "D").Value = "未找到该邮箱文件夹"
        End If
        
        Set objFolder = Nothing ' 释放对象，避免内存占用
    Next i
    
    ' 清理对象
    Set objnSpace = Nothing
    Set objOutlook = Nothing
    MsgBox "邮件统计完成！"
End Sub

额外提醒 #

• 确保Outlook已经打开，要是需要自动登录，可以在初始化后加一句objOutlook.Session.Logon；
• 如果文件夹不是默认收件箱，记得把代码里的"收件箱"改成你要统计的文件夹名称；
• 要是邮件数量特别多，还可以用Restrict方法过滤邮件，比遍历所有邮件快很多，比如：

  Dim filteredItems As Object
  Set filteredItems = objFolder.Items.Restrict("[ReceivedTime] >= '" & Format(targetDate, "ddddd hh:mm AMPM") & "' AND [ReceivedTime] < '" & Format(targetDate + 1, "ddddd hh:mm AMPM") & "'")
  emailCount = filteredItems.Count
  

  这种方式不用遍历每一封邮件，直接过滤出目标日期的邮件，效率会高很多！

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