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

Posted 2021-05-03

我有几个邮箱，我可以在我的Outlook配置文件中看到。其中一个邮箱，我们称之为“邮箱 - HUR”不断收到邮件。目前我的一个团队每天进入这个邮箱的收件箱，并将邮件移动（拖放）到收件箱的子文件夹中，名为Archive（我们是一个富有想象力的地段！）如果邮件超过24小时。

是否有任何方法可以设置宏来执行此任务？我知道我对VBA的简单方法，但从未在Outlook中使用它，也无法找出命名空间详细信息，以指向正确的邮箱而不是我的邮箱。

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

任何人都可以提供任何帮助都会很棒。

答案

您可能想尝试：

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

另一答案

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

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

另一答案

Fionnuala你摇滚！

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

Set objMoveFolder = GetNamespace("MAPI").PickFolder

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