RDO会话-循环浏览整个收件箱并移动电子邮件

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宏时，我将尝试使用它。

我假设，从你的问题没有答案的情况下，其他人也很少使用Redemption。

赎回网站暗示赎回代码的结构将与标准Outlook代码几乎相同。我只记得有一次写了一个宏，它对用户选择的项进行操作，但我记得代码看起来像你的代码。下面的代码是标准的Outlook，但我希望这足以让你创建等效的赎回代码。

您的宏具有注释' 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