0

感谢本网站提供的出色帮助，我找到了下面的代码 - 完美运行。我无法（非常尴尬）弄清楚如何遍历整个收件箱以移动所有电子邮件（而不是像下面的代码那样选择）。

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

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
4

1 回答 1

0

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

我假设您的问题没有答案，也很少有人使用 Redemption。

Redemption 网站暗示 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
于 2012-09-29T09:39:44.833 回答