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 

希望這可以幫助別人其他。