修改Outlook邮件提取VBA代码：解决仅提取一月数据及保留D列问题

以下是针对你的需求修改后的完整代码，同时修复了原代码中的附件提取逻辑错误：

Option Explicit

Sub GetMailInfo()
    Dim results()   As String
    Dim ws As Worksheet
    Dim arrAC As Variant
    Dim arrAttach As Variant
    Dim i As Long, j As Long
    Dim maxAttachCol As Integer
    
    ' 获取邮件数据
    results = ExportEmails(True)
    If UBound(results) = 0 Then Exit Sub ' 无数据时直接退出
    
    Set ws = Sheets("Outlook Results")
    
    ' 写入A-C列（发件人、接收时间、主题）
    ReDim arrAC(1 To UBound(results), 1 To 3)
    For i = 1 To UBound(results)
        arrAC(i, 1) = results(i, 1)
        arrAC(i, 2) = results(i, 2)
        arrAC(i, 3) = results(i, 3)
    Next i
    ws.Range("A1").Resize(UBound(arrAC), 3).Value = arrAC
    
    ' 写入附件列（从第39列开始）
    maxAttachCol = 0
    ' 找出数组中有数据的最后一列附件列
    For j = 39 To UBound(results, 2)
        For i = 1 To UBound(results)
            If results(i, j) <> "" Then
                maxAttachCol = j
                Exit For
            End If
        Next i
    Next j
    
    If maxAttachCol >= 39 Then
        ReDim arrAttach(1 To UBound(results), 1 To maxAttachCol - 38)
        For i = 1 To UBound(results)
            For j = 39 To maxAttachCol
                arrAttach(i, j - 38) = results(i, j)
            Next j
        Next i
        ws.Cells(1, 39).Resize(UBound(arrAttach), UBound(arrAttach, 2)).Value = arrAttach
    End If
    
    ' 冻结窗格
    ws.Range("A2").Select
    ActiveWindow.FreezePanes = True
    
    MsgBox "Completed"
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 numRows     As Long
    Dim startRow    As Long
    Dim jAttach     As Long        ' 附件计数器
    
    ' 初始化Outlook对象
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set strFolderName = objNamespace.PickFolder
    If strFolderName Is Nothing Then
        ReDim tempString(0 To 0, 0 To 0)
        ExportEmails = tempString
        Exit Function ' 用户取消选择文件夹
    End If
    
    Set mailFolderItems = strFolderName.Items
    mailFolderItems.Sort "[ReceivedTime]", False ' 按接收时间倒序排序
    
    ' 统计文件夹中邮件数量（排除非邮件项）
    numRows = 0
    For Each folderItem In mailFolderItems
        If IsMail(folderItem) Then
            numRows = numRows + 1
        End If
    Next folderItem
    
    ' 设置表头行
    If headerRow Then
        startRow = 1
    Else
        startRow = 0
    End If
    
    ' 调整数组大小
    ReDim tempString(1 To (numRows + startRow), 1 To 100)
    
    ' 写入表头
    If headerRow Then
        tempString(1, 1) = "SenderName"
        tempString(1, 2) = "ReceivedTime"
        tempString(1, 3) = "Subject"
        ' 生成附件列表头
        For jAttach = 1 To 50 ' 最多支持50个附件表头
            tempString(1, 39 + jAttach - 1) = "Attachment " & jAttach
        Next jAttach
    End If
    
    ' 遍历邮件项，写入数据
    i = 1 ' 数据行索引（从表头后开始）
    For Each folderItem In mailFolderItems
        If IsMail(folderItem) Then
            Set msg = folderItem
            
            With msg
                tempString(i + startRow, 1) = .SenderName
                tempString(i + startRow, 2) = .ReceivedTime
                tempString(i + startRow, 3) = .Subject
            End With
            
            ' 写入所有附件名称（修复原代码仅提取50+附件的错误）
            If msg.Attachments.Count > 0 Then
                For jAttach = 1 To msg.Attachments.Count
                    tempString(i + startRow, 39 + jAttach - 1) = msg.Attachments.Item(jAttach).DisplayName
                Next jAttach
            End If
            
            i = i + 1
        End If
    Next folderItem
    
    ExportEmails = tempString
End Function

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

关键修改说明 #

1. 保留D列及中间列数据

   • 删除原代码中清空整个工作表的Cells.ClearContents操作
   • 拆分数据写入逻辑：仅覆盖A-C列（邮件核心信息）和第39列及以后的附件列，D到38列完全保留原有内容
   • 避免了原数组写入时覆盖空列导致的数据丢失

2. 提取目标文件夹全部邮件

   • 新增邮件数量统计逻辑：先遍历文件夹统计所有MailItem数量，确保数组大小匹配实际邮件数，避免空行
   • 使用For Each遍历邮件项，配合IsMail判断，仅处理真正的邮件对象，跳过日历、任务等非邮件项
   • 修复附件提取逻辑：将原代码中仅提取50+附件的错误条件改为提取所有附件

3. 其他优化

   • 添加用户取消文件夹选择的容错处理，避免程序报错
   • 自动生成附件列表头，提升表格可读性
   • 优化排序逻辑，移除重复执行的代码

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