将收件箱子文件夹导出到循环到pst

时间:2016-05-10 18:02:50

标签: vba outlook-vba

要点: 如何在不知道所谓的内容的情况下调用收件箱的 subfolders ?在将它们导出到.pst的情况下,这甚至是可能的吗?

完整说明:

我在Outlook Exchange 2010环境中工作。

我尝试将电子邮件导出到大约30个用户的.pst文件。它们从服务器上的无限存储空间转移到1.5 GB。这尤其令人遗憾,因为由于政策和法律原因,用户必须保留文件。我已采取措施缩小尺寸,但其中一些收件箱非常庞大。

通过研究,我发现了一段代码,可以将与电子邮件帐户关联的所有项目导出到单个.pst,并且我已修改该代码以定位特定的 subfolder 在该帐户内。

接下来,我希望能够在收件箱下定位一系列 subfolders 。我能以某种方式遍历它们 - 没有指定它们的名字吗?这会在这种情况下起作用吗?注意:我有 userform ,允许他们选择要从中导出的帐户。

代码:

Option Explicit

Sub BackUpEmailInPST()
    Dim olNS As Outlook.NameSpace
    Dim olBackup As Outlook.Folder
    Dim bFound As Boolean
    Dim strPath As String
    Dim strDisplayName As String
    strDisplayName = "Backup " & Format(Date, "yyyymmdd")
    strPath = "C:\Users\TaylorMat\Documents\Attachments\" & strDisplayName &         ".pst"
    Set olNS = GetNamespace("MAPI")
    olNS.AddStore strPath
    Set olBackup = olNS.Folders.GetLast
    olBackup.Name = strDisplayName
    RunBackup olNS, olBackup
    olNS.RemoveStore olBackup
lbl_Exit:
    Set olNS = Nothing
    Set olBackup = Nothing
    Exit Sub
End Sub

Sub RunBackup(olNS As Outlook.NameSpace, olBackup As Outlook.Folder)
    Dim oFrm As New frmSelectAccount
    Dim strAcc As String
    Dim olStore As Store
    Dim olFolder As Folder
    Dim olNewFolder As Folder
    Dim i As Long
    With oFrm
        .BackColor = RGB(191, 219, 255)
        .Height = 190
        .Width = 240
        .Caption = "Backup E-Mail"
        With .CommandButton1
            .Caption = "Next"
            .Height = 24
            .Width = 72
            .Top = 126
            .Left = 132
        End With
        With .CommandButton2
            .Caption = "Quit"
            .Height = 24
            .Width = 72
            .Top = 126
            .Left = 24
        End With

        With .ListBox1
            .Height = 72
            .Width = 180
            .Left = 24
            .Top = 42
            For Each olStore In olNS.Stores
                If Not olStore.DisplayName = olBackup Then
                    .AddItem olStore
                End If
            Next olStore
        End With
    With .Label1
        .BackColor = RGB(191, 219, 255)
        .Height = 24
        .Left = 24
        .Width = 174
        .Top = 6
        .Font.Size = 10
        .Caption = "Select e-mail store to backup"
        .TextAlign = fmTextAlignCenter
    End With
    .Show
    If .Tag = 0 Then GoTo lbl_Exit
    With oFrm.ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                strAcc = .List(i)
                Exit For
            End If
        Next i
    End With
    Set olFolder = olNS.Stores(strAcc).GetDefaultFolder(olFolderInbox)
    Set olNewFolder = olFolder.Folders("Export")
    olNewFolder.CopyTo olBackup
    DoEvents
    Set olFolder = olNS.Stores(strAcc).GetDefaultFolder(olFolderSentMail)
    olFolder.CopyTo olBackup
End With
lbl_Exit:
    Unload oFrm
    Set olStore = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub

1 个答案:

答案 0 :(得分:0)

使用MAPIFolder.Folders集合循环遍历子文件夹。

你为什么使用Set olBackup = olNS.Folders.GetLast?系列不保证按任何特定顺序排列。使用文件夹名称(olNS.Folders.Item("Folder name"))