Outlook VBA实现多共享邮箱新邮件触发处理的方法求助

问题分析 #

原代码仅通过单个WithEvents变量监控GroupBox1的收件箱，新增olInboxItems2后未生效的核心原因是：

• 未提前声明第二个带WithEvents关键字的Items变量
• 未为第二个变量编写对应的ItemAdd事件处理过程

可行实现步骤 #

1. 声明多个监控变量 #

在模块顶部声明两个独立的WithEvents变量，分别对应两个共享邮箱的收件箱：

Private WithEvents olInboxItems1 As Items
Private WithEvents olInboxItems2 As Items

2. 初始化两个共享邮箱的收件箱 #

在Application_Startup过程中同时初始化两个监控对象：

Private Sub Application_Startup()
    Dim objNS As NameSpace
    Set objNS = Application.Session
    ' 初始化第一个共享邮箱收件箱
    Set olInboxItems1 = GetFolderPath("GroupBox1\Inbox").Items
    ' 初始化第二个共享邮箱收件箱
    Set olInboxItems2 = GetFolderPath("GroupBox2\Inbox").Items
    Set objNS = Nothing
End Sub

3. 复用处理逻辑（避免代码冗余） #

将原olInboxItems_ItemAdd中的核心逻辑抽成通用子过程，让两个事件都调用它，减少重复代码：

Private Sub ProcessNewMail(ByVal Item As Object)
    Dim objMsg As Outlook.MailItem
    Dim strFile_Path As String
    Dim objAttachments As Outlook.Attachments
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String ' 需设置实际保存路径

    ' 记录日志（可根据需求保留或删除）
    strFile_Path = "C:\temp\MyTestFile.txt"
    Open strFile_Path For Append As #1
    Write #1, "Start"
    Write #1, Now

    ' 确保当前Item是邮件对象
    If TypeOf Item Is MailItem Then
        Set objMsg = Item
        
        ' 设置附件保存路径（必须修改为实际存在的文件夹）
        strFolderpath = "C:\YourAttachmentSaveFolder\"
        
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        
        If lngCount > 0 Then
            ' 倒序遍历删除附件（避免集合索引混乱）
            For i = lngCount To 1 Step -1
                strFile = objAttachments.Item(i).FileName
                strFile = strFolderpath & strFile
                ' 保存附件
                objAttachments.Item(i).SaveAsFile strFile
            Next i
        End If
        
        ' 删除邮件
        objMsg.Delete
    End If

    ' 日志收尾
    Write #1, "Konec"
    Write #1, Now
    Close #1

    ' 释放对象
    Set objAttachments = Nothing
    Set objMsg = Nothing
End Sub

4. 编写两个邮箱的事件处理过程 #

分别为两个WithEvents变量编写ItemAdd事件，调用通用处理过程：

Private Sub olInboxItems1_ItemAdd(ByVal Item As Object)
    ProcessNewMail Item
End Sub

Private Sub olInboxItems2_ItemAdd(ByVal Item As Object)
    ProcessNewMail Item
End Sub

完整修改后代码 #

Private WithEvents olInboxItems1 As Items
Private WithEvents olInboxItems2 As Items

Private Sub Application_Startup()
    Dim objNS As NameSpace
    Set objNS = Application.Session
    Set olInboxItems1 = GetFolderPath("GroupBox1\Inbox").Items
    Set olInboxItems2 = GetFolderPath("GroupBox2\Inbox").Items
    Set objNS = Nothing
End Sub

Private Sub olInboxItems1_ItemAdd(ByVal Item As Object)
    ProcessNewMail Item
End Sub

Private Sub olInboxItems2_ItemAdd(ByVal Item As Object)
    ProcessNewMail Item
End Sub

Private Sub ProcessNewMail(ByVal Item As Object)
    Dim objMsg As Outlook.MailItem
    Dim strFile_Path As String
    Dim objAttachments As Outlook.Attachments
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String

    strFile_Path = "C:\temp\MyTestFile.txt"
    Open strFile_Path For Append As #1
    Write #1, "Start"
    Write #1, Now

    If TypeOf Item Is MailItem Then
        Set objMsg = Item
        
        ' ********** 修改为你的附件保存路径 **********
        strFolderpath = "C:\AttachmentSaveFolder\"
        
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        
        If lngCount > 0 Then
            For i = lngCount To 1 Step -1
                strFile = objAttachments.Item(i).FileName
                strFile = strFolderpath & strFile
                objAttachments.Item(i).SaveAsFile strFile
            Next i
        End If
        
        objMsg.Delete
    End If

    Write #1, "Konec"
    Write #1, Now
    Close #1

    Set objAttachments = Nothing
    Set objMsg = Nothing
End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer

    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    Set GetFolderPath = oFolder
    Exit Function

GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

注意事项 #

• 必须确保strFolderpath指向的文件夹已存在，否则保存附件会报错
• 若需扩展更多共享邮箱，只需重复添加WithEvents变量、初始化代码和对应的ItemAdd事件即可
• 原代码中objSelection变量未实际使用，已在通用过程中移除，避免资源浪费

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