如何按时间顺序提取指定发件人的Outlook邮件数据至Excel

Sub GetMailInfo()
    Dim results() As String
    
    ' 获取符合条件的邮件数据
    results = ExportEmails(True)
    
    ' 将数据粘贴到工作表
    If UBound(results) >= 1 Then
        Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
    End If
    
    MsgBox "完成"
End Sub

Function ExportEmails(Optional headerRow As Boolean = False) As String()
    Dim objOutlook As Object ' Outlook.Application
    Dim objNamespace As Object ' Outlook.Namespace
    Dim strFolderName As Object
    Dim mailFolderItems As Object ' Outlook.items
    Dim folderItem As Object
    Dim msg As Object ' Outlook.MailItem
    Dim tempString() As String
    Dim i As Long
    Dim currentRow As Long
    Dim startRow As Long
    Dim jAttach As Long ' 附件计数器
    
    ' 选择输出工作表并清除原有数据
    Sheets("Outlook Results").Select
    Sheets("Outlook Results").Cells.ClearContents
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set strFolderName = objNamespace.PickFolder
    Set mailFolderItems = strFolderName.Items
    
    ' 按收件时间升序排序（1代表升序，2代表降序）
    mailFolderItems.Sort "[ReceivedTime]", 1
    
    ' 设置起始行（是否包含表头）
    If headerRow Then
        startRow = 1
        ' 初始化数组，预留足够列数
        ReDim tempString(1 To mailFolderItems.Count + startRow, 1 To 100)
        ' 写入表头
        tempString(1, 1) = "发件人名称"
        tempString(1, 2) = "收件日期"
        tempString(1, 3) = "收件时间"
        tempString(1, 4) = "邮件主题"
        currentRow = startRow
    Else
        startRow = 0
        ReDim tempString(1 To mailFolderItems.Count, 1 To 100)
        currentRow = 0
    End If
    
    ' 遍历文件夹中的项目
    For i = 1 To mailFolderItems.Count
        Set folderItem = mailFolderItems.Item(i)
        
        ' 仅处理邮件项目，且发件人为jkcopy@gmail.com
        If IsMail(folderItem) Then
            Set msg = folderItem
            If msg.SenderEmailAddress = "jkcopy@gmail.com" Then
                currentRow = currentRow + 1
                
                With msg
                    tempString(currentRow, 1) = .SenderName
                    ' 拆分日期和时间为单独列
                    tempString(currentRow, 2) = DateValue(.ReceivedTime)
                    tempString(currentRow, 3) = TimeValue(.ReceivedTime)
                    tempString(currentRow, 4) = .Subject
                    
                    ' 添加附件名称（修复原代码逻辑错误，改为存在附件即添加）
                    If .Attachments.Count > 0 Then
                        For jAttach = 1 To .Attachments.Count
                            tempString(currentRow, 39 + jAttach) = .Attachments.Item(jAttach).DisplayName
                        Next jAttach
                    End If
                End With
            End If
        End If
    Next i
    
    ' 调整数组大小以匹配实际有效数据行数
    If currentRow > 0 Then
        ReDim Preserve tempString(1 To currentRow, 1 To 100)
    Else
        ' 若无有效数据，返回空数组
        ReDim tempString(1 To 1, 1 To 4)
        If headerRow Then
            tempString(1, 1) = "发件人名称"
            tempString(1, 2) = "收件日期"
            tempString(1, 3) = "收件时间"
            tempString(1, 4) = "邮件主题"
        End If
    End If
    
    ExportEmails = tempString
    
    ' 冻结窗格
    If currentRow >= 2 Then
        Range("A2").Select
        ActiveWindow.FreezePanes = True
    End If
End Function

Function IsMail(itm As Object) As Boolean
    IsMail = (TypeName(itm) = "MailItem")
End Function

关键修改说明 #

• 按日期时间排序: 在获取邮件集合后添加mailFolderItems.Sort "[ReceivedTime]", 1，按收件时间升序排列（若需降序可改为2）。
• 筛选指定发件人: 增加条件判断If msg.SenderEmailAddress = "jkcopy@gmail.com" Then，仅处理该发件人的邮件。
• 拆分日期与时间: 将原单一的ReceivedTime拆分为DateValue(.ReceivedTime)（日期部分）和TimeValue(.ReceivedTime)（时间部分），分别存入两列，同时更新表头。
• 修复附件逻辑: 原代码仅在附件数大于50时才添加附件名称，改为If .Attachments.Count > 0 Then，只要有附件就显示。
• 优化数组行数: 使用currentRow计数器跟踪有效数据行，避免空行，最后调整数组大小匹配实际数据量。
• 适配系统日期格式: 使用DateValue返回日期序列号，Excel会自动根据你的系统格式（ddmmyyyy）显示日期。

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