Question

我有多个帐户附加到Outlook 2010，我想创建一个脚本，将邮件从超过X天的特定帐户移动到.pst文件以进行本地存储。我找到了大量的脚本来将邮件从默认收件箱移动到任何地方，但没有指定帐户。

我知道您可以在使用

发送电子邮件时指定帐户

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

但是我找不到任何寻找到另一个帐户的内容。

我找到了文件夹的商店参考（\ Inbox和\ Sent），我知道如何指定旧日期。事实上，我有一个完整的脚本，但只能在我的主帐户中，而不是其他任何一个。我坚持使用语法来查看帐户2。

我确定我的部分问题是我没有正确地表达我的问题，但我开始陷入无休止的相同搜索结果循环中。任何人都可以给我一个正确的方向吗？

感谢。

Answer 1

经过一些搜索和测试后，我想出了以下解决方案。这实际上是来自2009年的stackoverflow帖子：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 as Integer以允许例程处理两个不同的源和目标文件夹。如果我将Sub名称更改为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

希望这有助于其他人。

VBA - Outlook从特定帐户移动旧邮件

1 个答案: