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

我有一些在Excel中使用VBA的经验，但我是在Outlook中迈出了第一步。我需要将指定Outlook文件夹（

Inbox\input

）中的所有电子邮件以.msg文件的形式保存到磁盘（

D:\myArchive\Email\

）中，并将邮件项目移动到Outlook中的存档文件夹（

Inbox\archive

）

我在Outlook中设置了一个邮件规则，可以将邮件移动到存档文件夹，并在下面运行一个脚本，该脚本实际执行我需要的操作。问题是我偶尔会出现邮件规则错误弹出窗口，我很难找到原因。因此，希望放弃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

---

以下代码假定

输入

和

存档

文件夹都位于默认收件箱中

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)

---

移动或删除时，请使用反向循环。每一个都是一个向前计数循环。@尼顿感谢您捕捉到这一点，我将相应地修改我的帖子。我已经修改了我的帖子。@Domenic很抱歉没有澄清这一点-事实上，目标文件夹不在我的默认邮箱中-它是Office365中的共享邮箱（在Outlook中未设置为单独的帐户）。我怎样才能找到不同的邮箱？此外，我也不知道如何以默认邮箱收件箱本身为目标。在收件箱的子文件夹中工作很好！见我编辑的帖子。