VBA - Outlook移动来自特定帐户的旧邮件

Question

我有多个帐户附加到Outlook 2010，我想创建一个脚本，将邮件从X天以前的特定帐户移动到本地存储的.pst文件。我发现了大量的脚本，可以将邮件从默认收件箱移至任何地方，但不会指定帐户。

我知道你可以使用

Set OutMail.SendUsingAccount = Outlook.Application.Session.Accounts.Item(2)

发送电子邮件时指定的帐户，但我不能为寻找到另一个帐户发现任何东西。

我发现了文件夹（\ Inbox和\ Sent）的商店参考，我知道如何指定旧的日子。事实上，我有一个完整的脚本，但只能在我的主帐户中使用，而不能在其他帐户中使用。我被卡在语法上，使它看起来在帐户2.

我敢肯定我的问题的一部分是我没有措辞我的问题很正确，但我开始陷入无限循环相同的搜索结果。任何人都可以给我一个正确的方向？

谢谢。

Answer 1

经过一些更多的搜索和测试，我想出了以下解决方案。这实际上是从这里的一个2009年的帖子在这里：Original VBA

它使用公共职能来建立文件夹的位置和一个子程序来查找60天以上的接收日期，并将这些文件移动到指定的位置。

的公共职能为：

Public Function GetFolder(strFolderPath As String) As MAPIFolder 
Dim objNS As NameSpace 
Dim colFolders As folders 
Dim objFolder As MAPIFolder 
Dim arrFolders() As String 
Dim i As Long 

On Error GoTo TrapError 

strFolderPath = Replace(strFolderPath, "/", "\") 
arrFolders() = Split(strFolderPath, "\") 

Set objNS = GetNamespace("MAPI") 

On Error Resume Next 

Set objFolder = objNS.folders.Item(arrFolders(0)) 

If Not objFolder Is Nothing Then 
    For i = 1 To UBound(arrFolders) 
     Set colFolders = objFolder.folders 
     Set objFolder = Nothing 
     Set objFolder = colFolders.Item(arrFolders(i)) 

     If objFolder Is Nothing Then 
      Exit For 
     End If 
    Next 
End If 

On Error GoTo TrapError 

Set GetFolder = objFolder 
Set colFolders = Nothing 
Set objNS = Nothing 

Exit_Proc: 
    Exit Function 

TrapError: 
    MsgBox Err.Number & " " & Err.Description 

End Function 

，做实际工作的子程序如下。

我添加了Pass作为Integer以允许例程在两个不同的源文件夹和目标文件夹中工作。如果我将子名称更改为Application_Startup，它将在Outlook启动时运行。

PST文件夹名称\存档 - 收件箱 - 在Outlook PST文件夹名称与子文件夹

电子邮件帐户名称\收件箱 - 在Outlook帐户名与子文件夹

Sub MoveOldEmail() 
    Dim oItem As MailItem 
    Dim objMoveFolder As MAPIFolder 
    Dim objInboxFolder As MAPIFolder 
    Dim i As Integer 
    Dim Pass As Integer 

For Pass = 1 To 2 
    If Pass = 1 Then 
     Set objMoveFolder = GetFolder("PST Folder Name\Archive-Inbox") 
     Set objInboxFolder = GetFolder("Email Account Name\Inbox") 
    ElseIf Pass = 2 Then 
     Set objMoveFolder = GetFolder("PST Folder Name\Archive-Sent Items") 
     Set objInboxFolder = GetFolder("Email Account Name\Sent Items") 
    End If 

    For i = objInboxFolder.Items.Count - 1 To 0 Step -1 
     With objInboxFolder.Items(i) 
     ''Error 438 is returned when .receivedtime is not supported 
     On Error Resume Next 

      If .ReceivedTime < DateAdd("d", -60, Now) Then 
       If Err.Number = 0 Then 
       .Move objMoveFolder 
       Else 
        Err.Clear 
       End If 
      End If 
      End With 

     Next    
    Next Pass 

     Set objMoveFolder = Nothing 
     Set objInboxFolder = Nothing 

    End Sub 

希望这可以帮助别人其他。