如何用VBA访问Outlook 365组并处理未读邮件附件

我是名为"Reporting"的Outlook 365组的成员及管理员之一，该组每日接收带有xls/csv格式附件的邮件，在Outlook客户端中可通过「群组>Reporting」路径查看这些邮件。我希望通过VBA遍历该组内所有未读邮件，将附件保存到本地电脑，并将邮件标记为已读。此前我已针对其他普通Outlook文件夹实现了该功能，但目前无法用VBA访问Outlook 365组，经搜索未找到解决方案。

以下是我用于读取普通文件夹的VBA代码：

Sub Save_UnReadFiles_Auto_Report_NWP()
Dim O_App As Outlook.Application
Dim O_Space As Outlook.NameSpace 
Dim O_Folder As Outlook.MAPIFolder
Dim O_Mail As Outlook.MailItem
Dim O_Att As Outlook.Attachment
'-----------------------------------------------------------------------------
Const AutoReport_Folder As String = "A:\2022\Werk\AUTO_REPORT_NWP"
'-----------------------------------------------------------------------------
Dim strFilter As String
Dim TTDate As Date
Dim strFilePath As String
Dim strFileName As String
Dim MailID() As String, i As Integer, ii As Integer
'-----------------------------------------------------------------------------
Const MailSubject_WAE_1 As String = "WD-WAE_1_email"
Const MailSubject_WAE_2 As String = "WD-WAE_2_email"
Const MailSubject_WAE_3 As String = "WD-WAE_3_email"
Const MailSubject_WAE_4 As String = "WD-WAE_4_email"
Const MailSubject_WAE_5 As String = "WD-WAE_5_email"
'-----------------------------------------------------------------------------
    Set O_App = CreateObject("Outlook.Application")
    Set O_Space = O_App.GetNamespace("MAPI")
    Set O_Folder = O_Space.Folders("AUTO_REPORT_NWP")
    Set O_Folder = O_Folder.Folders("Inbox")
    i = 0
    strFilter = "[UNREAD]=TRUE"
    For Each O_Mail In O_Folder.Items.Restrict(strFilter)
        TTDate = O_Mail.ReceivedTime - 1
        strFilePath = AutoReport_Folder & "\" & Format(TTDate, "mm") & ". " & Format(TTDate, "mmmm") & "\"
        strFilePath = strFilePath & Format(TTDate, "dd") & Format(TTDate, "mm") & Format(TTDate, "yy")
        strFileName = ""
        Select Case O_Mail.Subject
            Case MailSubject_WAE_1
                strFileName = "WD-WAE_1.csv"
            Case MailSubject_WAE_2
                strFileName = "WD-WAE_2.csv"
            Case MailSubject_WAE_3
                strFileName = "WD-WAE_3.csv"
            Case MailSubject_WAE_4
                strFileName = "WD-WAE_4.csv"
            Case MailSubject_WAE_5
                strFileName = "WD-WAE_5.csv"
        End Select
        If strFileName <> "" Then
            i = i + 1
            For Each O_Att In O_Mail.Attachments
                If strFileName = "keep_original_name" Then
                    On Error Resume Next
                    O_Att.SaveAsFile strFilePath & "\" & O_Att.FileName
                Else
                    On Error Resume Next
                    O_Att.SaveAsFile strFilePath & "\" & strFileName
                End If
            Next
            ReDim Preserve MailID(1 To i)
            MailID(i) = O_Mail.EntryID
        End If
    Next
    If i <> 0 Then
        For ii = 1 To UBound(MailID)
            Set O_Mail = O_Space.GetItemFromID(MailID(ii))
            O_Mail.UnRead = False
            Set O_Mail = Nothing
        Next
    End If
    Set O_Folder = Nothing
    Set O_Space = Nothing
    Set O_App = Nothing
End Sub

Outlook 365组无法通过传统MAPIFolder直接访问，需通过GetDefaultFolder(olFolderGroupMailboxes)获取组邮箱根目录，再定位到目标组的收件箱。以下是修改后的代码：

Sub Save_UnReadFiles_Reporting_Group()
Dim O_App As Outlook.Application
Dim O_Space As Outlook.NameSpace
Dim O_GroupRoot As Outlook.MAPIFolder
Dim O_GroupFolder As Outlook.MAPIFolder
Dim O_Mail As Outlook.MailItem
Dim O_Att As Outlook.Attachment
'-----------------------------------------------------------------------------
Const Save_Path As String = "A:\2022\Werk\Reporting_Attachments" ' 修改为你的保存路径
Const Target_Group_Name As String = "Reporting" ' 目标组名称
'-----------------------------------------------------------------------------
Dim strFilter As String
Dim TTDate As Date
Dim strFilePath As String
Dim strFileName As String
Dim MailID() As String, i As Integer, ii As Integer
'-----------------------------------------------------------------------------
Const MailSubject_WAE_1 As String = "WD-WAE_1_email"
Const MailSubject_WAE_2 As String = "WD-WAE_2_email"
Const MailSubject_WAE_3 As String = "WD-WAE_3_email"
Const MailSubject_WAE_4 As String = "WD-WAE_4_email"
Const MailSubject_WAE_5 As String = "WD-WAE_5_email"
'-----------------------------------------------------------------------------
    Set O_App = CreateObject("Outlook.Application")
    Set O_Space = O_App.GetNamespace("MAPI")
    
    ' 获取组邮箱根目录
    Set O_GroupRoot = O_Space.GetDefaultFolder(olFolderGroupMailboxes)
    
    ' 遍历找到目标组
    For Each O_GroupFolder In O_GroupRoot.Folders
        If O_GroupFolder.Name = Target_Group_Name Then
            ' 定位到组的收件箱
            Set O_GroupFolder = O_GroupFolder.Folders("Inbox")
            Exit For
        End If
    Next
    
    ' 检查是否找到目标组
    If O_GroupFolder Is Nothing Then
        MsgBox "未找到名为" & Target_Group_Name & "的Outlook组", vbExclamation
        GoTo Cleanup
    End If
    
    i = 0
    strFilter = "[UNREAD]=TRUE"
    For Each O_Mail In O_GroupFolder.Items.Restrict(strFilter)
        TTDate = O_Mail.ReceivedTime - 1
        strFilePath = Save_Path & "\" & Format(TTDate, "mm") & ". " & Format(TTDate, "mmmm") & "\"
        strFilePath = strFilePath & Format(TTDate, "dd") & Format(TTDate, "mm") & Format(TTDate, "yy")
        
        ' 创建目录（如果不存在）
        On Error Resume Next
        MkDir strFilePath
        On Error GoTo 0
        
        strFileName = ""
        Select Case O_Mail.Subject
            Case MailSubject_WAE_1
                strFileName = "WD-WAE_1.csv"
            Case MailSubject_WAE_2
                strFileName = "WD-WAE_2.csv"
            Case MailSubject_WAE_3
                strFileName = "WD-WAE_3.csv"
            Case MailSubject_WAE_4
                strFileName = "WD-WAE_4.csv"
            Case MailSubject_WAE_5
                strFileName = "WD-WAE_5.csv"
        End Select
        
        If strFileName <> "" Then
            i = i + 1
            For Each O_Att In O_Mail.Attachments
                ' 只处理xls/csv格式附件
                If LCase(Right(O_Att.FileName, 4)) = ".xls" Or LCase(Right(O_Att.FileName, 4)) = ".csv" Then
                    On Error Resume Next
                    O_Att.SaveAsFile strFilePath & "\" & strFileName
                    On Error GoTo 0
                End If
            Next
            ReDim Preserve MailID(1 To i)
            MailID(i) = O_Mail.EntryID
        End If
    Next
    
    ' 标记邮件为已读
    If i <> 0 Then
        For ii = 1 To UBound(MailID)
            Set O_Mail = O_Space.GetItemFromID(MailID(ii))
            O_Mail.UnRead = False
            O_Mail.Save
            Set O_Mail = Nothing
        Next
        MsgBox "已处理" & i & "封未读邮件，附件已保存", vbInformation
    Else
        MsgBox "未找到未读邮件", vbInformation
    End If

Cleanup:
    Set O_GroupFolder = Nothing
    Set O_GroupRoot = Nothing
    Set O_Space = Nothing
    Set O_App = Nothing
End Sub

关键修改说明 #

• 使用olFolderGroupMailboxes枚举值获取组邮箱的根目录，替代原有的普通文件夹定位方式
• 增加了目录创建逻辑，避免保存时因路径不存在报错
• 新增了附件格式过滤，只处理xls/csv类型的附件
• 增加了错误提示，便于排查未找到组的情况

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