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

我想知道是否有一种方法可以使用VBA/Outlook查看大量个人文件夹（全部添加到Outlook并称为个人文件夹），并将收件箱（该文件夹将始终称为收件箱）的内容复制到单个PST/收件箱/文件夹中。个人文件夹的数量因电子邮件搜索完成（GVault）而异

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

其目的是为用户提供一个PST，其中包含所有电子邮件

这是简化我们的电子邮件存档搜索过程的一部分，该过程为搜索中找到的每个电子邮件地址创建一个文件夹+PST（good old Google…）。显然，将它们合并到一个PST中是一场噩梦，我们可以将其交给用户。可以（使用Outlook）手动将每个PST与主PST组合，但这远远不能实现过程自动化+可能有大量单独的电子邮件地址

最初的问题是将所有PST放入Outlook，这已经解决，但格式如上所述（单独添加PST）

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

谢谢

---

Dan

下面的代码将把outlook附加的PST文件复制到名为“收件箱”（任何情况下）的文件夹中，并循环到PST调用的“主PST”文件夹中

---

包括非常小的错误检查，我不认为这是最后的障碍，但更多的是一个起点。到目前为止，您尝试了什么？我很感激这看起来对我来说并没有太多的努力，但这已经持续了好几个小时了，我在两周前才开始研究VBA，所以我倾向于很快就遇到困难。在我看来，从其他人那里添加不符合我要求的代码只会引起混乱…对我来说。感谢Steve，我会测试并让你知道。嗨@stevebiko，我在第一次运行时出错，尝试删除end if和next，但错误不断出现。布局有结束如果没有结束如果再次感谢关于格式，我没有运气编码换行符用两个空格结束一行以添加一个换行符：我尝试了新代码，但返回一个错误，说明“对象不支持此方法”。我尝试替换代码中显示“objItem.copy copyToFolder”改为“ActiveDocument.copy copyToFolder”，但它现在返回一个错误“Object required”@stevebiko

'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