Question

感谢本网站提供的出色帮助，我找到了以下代码 - 效果很好。我不能（令人尴尬地）弄清楚如何遍历整个收件箱以移动所有电子邮件（而不是像下面的代码一样选择）。

任何帮助都非常感激。赞约翰

Sub MoveWithRecDate()
' Moves selected emails with correct dates maintained

Dim objNS As Outlook.NameSpace
Dim Session As Redemption.RDOSession
Dim objRDOFolder As Redemption.RDOFolder
Dim objItem As Outlook.MailItem
Dim objRDOMail As Redemption.RDOMail

Set objNS = Application.GetNamespace("MAPI")
Set Session = CreateObject("Redemption.RDOSession")
Session.Logon
Set inbox = Session.GetDefaultFolder(olFolderInbox)
Set objRDOFolder = inbox.Parent.Folders("Cabinet")

For Each objItem In Application.ActiveExplorer.Selection
     Set objRDOMail = Session.GetMessageFromID(objItem.EntryID)
     objRDOMail.Move objRDOFolder
Next

End Sub

Answer 1

在阅读你的问题之前，我没有听说过救赎。它看起来很有趣，所以感谢您提供的信息;我下次需要编写一个新的Outlook宏时会尝试它。

我假设你的问题没有答案，很少有人使用救赎。

赎回网站暗示赎回代码的结构几乎与标准的Outlook代码完全相同。我只记得曾经写过一个用户选择的项目的宏，但我的回忆是代码看起来像你的。下面的代码是标准的Outlook，但我希望这足以让您创建等效的Redemption代码。

你的宏有评论' Moves selected emails with correct dates maintained。这意味着您认为有一种方法可以移动电子邮件，以便不维护日期。我不知道这样的方法。

以下代码检查收件箱中的每个项目。我不想将所有内容从我的收件箱中移出，因此我跳过了不是邮件项目而且不是来自特定发件人的项目。

我希望这足以让你前进。

Sub MoveWithRecDate()

  Dim FolderDest As MAPIFolder
  Dim ItemToBeMoved As Boolean
  Dim ItemCrnt As Object
  Dim FolderSrc As MAPIFolder

  Set FolderSrc = CreateObject("Outlook.Application"). _
              GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
  Set FolderDest = FolderSrc.Parent.Folders("Cabinet")

  For Each ItemCrnt In FolderSrc.Items
    ItemToBeMoved = True   ' Assume item to be moved until discover otherwise
    With ItemCrnt
      If .Class = olMail Then
        If .SenderEmailAddress <> "noreply@which.co.uk" Then
          ' Mail item not from Which
          ItemToBeMoved = False
        End If
      Else
        ' Not mail item so do not move
        ItemToBeMoved = False
      End If
      If ItemToBeMoved Then
        .Move FolderDest
      End If
    End With
  Next

End Sub

RDO会话 - 遍历整个收件箱并移动电子邮件

1 个答案: