1

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

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

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

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

4

3 回答 3

4

您可能想尝试：

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
于 2009-12-16T13:47:50.953 回答
0

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

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

于 2009-12-16T12:27:34.897 回答
0

Fionnuala 你摇滚！

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

Set objMoveFolder = GetNamespace("MAPI").PickFolder

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

于 2017-12-18T16:53:20.657 回答