使用 VBA/Outlook 将多个个人文件夹收件箱合并为一个

Question

我想知道是否有办法使用 VBA/Outlook 来查看多个个人文件夹（全部添加到 Outlook 并称为个人文件夹）并将收件箱的内容（该文件夹将始终称为收件箱）复制到单个 PST/收件箱/文件夹。个人文件夹的数量取决于完成的电子邮件搜索 (GVault)。

个人文件夹 - 收件箱， 个人文件夹 - 收件箱， 个人文件夹 - 收件箱， 最终个人文件夹 - 收件箱

目的是为用户提供一份包含所有电子邮件的 PST。

这是简化我们的电子邮件存档搜索过程的尝试的一部分，该过程为搜索中找到的每个电子邮件地址创建一个文件夹 + PST（好老的谷歌......）显然将它们全部组合成一个 PST 是一场噩梦然后我们可以将其提供给用户。可以（使用 Outlook）手动将每个 PST 与主 PST 组合，但这远非自动化流程 + 可能存在大量单独的电子邮件地址。

最初的问题是把所有的 PST 都带入 Outlook，这已经解决了，但格式如上所述（单独的 PST 全部添加）。

任何帮助都将不胜感激，因为我无法克服这最后一道障碍，在 Outlook 中确实有一些脚本可以操纵 PST，但他们只是不这样做。

谢谢 丹

Answer 1

以下代码将循环您的 Outlook 附加 PST 文件，将名为“收件箱”（任何情况）文件夹中的文件复制到名为“主 PST”的 PST 中

包括非常琐碎的错误检查

'include reference to Microsoft Outlook XX.0 Object Library
Public Sub copyInbox()
    Dim ns As Outlook.Namespace

    On Error GoTo hell

    Dim sourceFolder As Outlook.MAPIFolder
    Dim copyToFolder As Outlook.MAPIFolder
    Dim subfolder As Outlook.MAPIFolder
    Dim objItem As Outlook.MailItem
    Dim objItemCopy  As Outlook.MailItem
    Set ns = Application.GetNamespace("MAPI")
    Set copyToFolder = ns.Folders("MASTER PST").Folders("Inbox")
    'Personal folder called 'MASTER PST' with inbox subfolder must exist
    For Each sourceFolder In ns.Folders
        For Each subfolder In sourceFolder.Folders
            If Trim(UCase(subfolder.Name)) = "INBOX" Then
                For Each objItem In subfolder.Items
                    'modified below to use copy as per MSDN
                    'https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/mailitem-copy-method-outlook
                    Set objItemCopy = objItem.Copy
                    objItemCopy.Move copyToFolder
                Next
            End If
            'copy items in subfolders in inbox can be added here
        Next
    Next
    Exit Sub:
hell:
    MsgBox Err.Description, vbExclamation, Err.Source
End Sub