将 Outlook 邮件从一个邮箱收件箱移动到同一邮箱中的不同文件夹

Question

我有几个邮箱，可以在我的 Outlook 配置文件中看到它们。其中一个邮箱，我们称之为“邮箱 - HUR”，不断收到消息。目前，我的团队成员每天都会进入此邮箱的收件箱，如果邮件已存在超过 24 小时，则将邮件移动（拖放）到收件箱中名为“存档”的子文件夹中（我们是一个富有想象力的人！）。

有什么方法可以设置宏来完成这项任务吗？我知道使用 VBA 的简单方法，但从未在 Outlook 中使用过它，并且无法找出命名空间详细信息来将我指向正确的邮箱而不是我的邮箱。

不幸的是我无法访问Exchange服务器，只能使用outlook客户端。

任何人能提供的任何帮助都会很棒。

Answer 1

您可能想尝试：

Sub MoveOldEmail()

Dim oItem As MailItem
Dim objMoveFolder As MAPIFolder
Dim objInboxFolder As MAPIFolder
Dim i As Integer

    Set objMoveFolder = GetFolder("Personal Folders\Inbox\Archive")
    Set objInboxFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

    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("h", -24, Now) Then
                If Err.Number = 0 Then
                    .Move objMoveFolder
                Else
                    Err.Clear
                End If
            End If
        End With

    Next

    Set objMoveFolder = Nothing
    Set objInboxFolder = Nothing

End Sub

Public Function GetFolder(strFolderPath As String) As MAPIFolder
'' strFolderPath needs to be something like
''   "Public Folders\All Public Folders\Company\Sales" or
''   "Personal Folders\Inbox\My Folder"

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

Answer 2

您应该设置邮箱规则。 工具|规则向导

如果您使用的 Exchange 服务器具有将电子邮件移至特定文件夹的 Outlook 规则，则可以使用 Exchange 中的邮箱管理器在特定时间段后从该文件夹中删除邮件。有关详细信息，请参阅此文章。

Answer 3

菲奥诺拉你太棒了！

几个月来我一直在寻找类似问题的解决方案。由于我的公司限制，我无法使用 UDF（在我个人上工作得很好）；在子 MoveOldEmail 中，我改为使用：

Set objMoveFolder = GetNamespace("MAPI").PickFolder

很酷的事情是，这似乎可以让我在与 Outlook 关联的电子邮件帐户之间移动（至少在公司弄清楚之前）。