Outlook 赎回：带有 ReceivedTime 修改的静默导入

如何解决Outlook 赎回：带有 ReceivedTime 修改的静默导入

请帮助自动化由 2 个订阅组成的流程：

1. 导入 - 我需要在没有目标和目标文件夹选择对话框的情况下进行静默导入。 我需要导入到 Outlook 中的“INBox/Imported”子文件夹，并想了解在此代码中我可以明确提及它的位置。 我需要从文件夹“D:\Emails”中抓取 .EML 文件，而无需用于文件夹选择的冗余对话：

Sub Redemp()
Dim objShell: Set objShell = CreateObject("Shell.Application")
Dim objFolder: Set objFolder = objShell.browseForFolder(0,"Select the folder containing eml-files",0)

Dim Item
If (Not objFolder Is nothing) Then
  Set WShell = CreateObject("WScript.Shell")
  Set objOutlook = CreateObject("outlook.application")
  Set Folder = objOutlook.Session.PickFolder
  If Not Folder Is nothing Then
    For Each Item In objFolder.Items
      If Right(Item.name,4) = ".eml" And Item.IsFolder = False Then
        Set objpost = Folder.Items.Add(6)
        Set objSafePost = CreateObject("Redemption.SafePostItem")
        objSafePost.Item = objpost
        objSafePost.Import Item.Path,1024
        objSafePost.MessageClass = "IPM.Note"
        ' remove IPM.Post icon
    Set utils = CreateObject("Redemption.MAPIUtils")
    PrIconIndex = &H10800003
        utils.HrSetoneProp objSafePost,PrIconIndex,256,True 'Also saves the message
      End If
    Next
  End If
End If

MsgBox "Import completed.",64,"Import EML"

Set objFolder = nothing
Set objShell = nothing
End Sub

此外，最好避免导入的邮件出现在 Outlook 中，就像我已经开始回复一样（不是很方便）。如果我使用上面的代码并选择导入的消息，它看起来不像最初收到的，而是看起来像我回复的文本。

2. 我需要将下面的代码与上面的导入过程统一起来，以纠正导入消息的 ReceivedTime 属性（或者它可以在导入前修改 EML 文件，操作顺序并不重要）。

Sub Redemp_sentreceived()
    Set rSession = CreateObject("Redemption.RDOSession")
    rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
    Set Msg = rSession.GetRDOObjectFromOutlookObject(Application.ActiveExplorer.CurrentFolder)
    For Each Item In Msg.Items
        Item.ReceivedTime = Item.SentOn
        Item.Save
    Next
End Sub

最终导入的 .EML 文件应位于目标文件夹中，并具有正确的 ReceivedTime。 非常感谢您提前帮助我！

解决方法

在这种情况下真的没有理由使用 Safe*Item 对象 - 使用 RDOSession 对象，就像在第二个示例中一样设置 MAPIOBJECT 属性。

我的头顶：

Set rSession = CreateObject("Redemption.RDOSession")
rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set folder = rSession.GetDefaultFolder(plFolderInbox).Folders.Items("Imported")
Set fileFolder = objFSO.GetFolder("D:\Emails")
For Each objFile in fileFolder.Files
    set msg = folder.Items.Add("IPM.Note")
    msg.Sent = true
    msg.Import objFile.Path,1031
    msg.Save
Next

,

问题出在导入中指出的数字（我更改了 1031 -> 1024），现在它就像一个魅力！

Sub MailImport()
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")

Set rSession = CreateObject("Redemption.RDOSession")
rSession.MAPIOBJECT = Application.Session.MAPIOBJECT
Set Folder = rSession.GetDefaultFolder(olFolderInbox)
Set fileFolder = objFSO.GetFolder("D:\Emails")

For Each objFile In fileFolder.Files
    Set msg = Folder.Items.Add("IPM.Note")
    msg.sent = True
    msg.Import objFile.Path,1024
    msg.ReceivedTime = msg.SentOn
    msg.Save
    objFile.Delete
Next

Set objFSO = Nothing
End Sub