使用 VBA 将所有 Outlook 邮件项目保存到磁盘

Question

我在 Excel 中使用 VBA 有一些经验，但我的第一步是在 Outlook 中。我需要将指定 Outlook 文件夹 (Inbox\input) 中的所有电子邮件作为 .msg 文件保存到磁盘 (D:\myArchive\Email\) 并将邮件项目移动到 Outlook 中的存档文件夹 (Inbox\archive) .

我在 Outlook 中设置了一个邮件规则，将邮件移动到存档文件夹并运行下面的脚本，该脚本实际上可以满足我的需要。问题是我偶尔会收到邮件规则错误弹出窗口，我很难找出原因。因此希望摆脱 Outlook 邮件规则并“按需”循环浏览所有文件夹内容。

如何将其转换为在 Outlook 文件夹中循环并替换邮件项目？目前运行展望 2019。谢谢！

编辑：抱歉，澄清晚了 - 目标文件夹在另一个邮箱（Office 365 共享邮箱）中。如何定位不同的帐户？

Public Sub saveEmailtoDisk(itm As Outlook.MailItem)
    Dim saveFolder, msgName1, msgName2 As String
    
    saveFolder = "D:\myArchive\Email\"
    
    msgName1 = Replace(itm.Subject, ":", "")
    msgName2 = Replace(msgName1, "/", "_")
    
    itm.SaveAs saveFolder & msgName2 & ".msg", olMSG
    
End Sub

Answer 1

以下代码假定 input 和 archive 文件夹都位于默认收件箱中。

Public Sub saveAndArchiveInputEmails()

    Dim saveFolder As String
    saveFolder = "D:\myArchive\Email\"
    
    Dim sourceFolder As Folder
    Dim destFolder As Folder
    With Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
        Set sourceFolder = .Folders("input")
        Set destFolder = .Folders("archive")
    End With

    Dim itm As Object
    Dim i As Long
    With sourceFolder
        For i = .Items.Count To 1 Step -1
            Set itm = .Items(i)
            If TypeName(itm) = "MailItem" Then
                saveEmailtoDisk saveFolder, itm
                itm.Move destFolder
            End If
        Next i
    End With
    
End Sub

Public Sub saveEmailtoDisk(ByRef saveFolder As String, ByVal itm As Object)
    
    Dim msgName1, msgName2 As String
    
    msgName1 = Replace(itm.Subject, ":", "")
    msgName2 = Replace(msgName1, "/", "_")
    
    itm.SaveAs saveFolder & msgName2 & ".msg", olMSG
    
End Sub

编辑

对于共享邮箱，请尝试以下操作...

With Application.GetNamespace("MAPI")

    Dim sharedEmail As Recipient
    Set sharedEmail = .CreateRecipient("someone@abc.com")
    
    Dim sourceFolder As Folder
    Set sourceFolder = .GetSharedDefaultFolder(sharedEmail, olFolderInbox).Folders("input")
    
    Dim destFolder As Folder
    Set destFolder = .GetSharedDefaultFolder(sharedEmail, olFolderInbox).Folders("archive")
    

End With

对于您的默认收件箱...

Dim myInbox As Folder
Set myInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

使用 VBA 将所有 Outlook 邮件项目保存到磁盘

Save all Outlook mailitems to disk with VBA

outlook

vba