保存一个 RDOMMailItem 并不总是执行

问题描述

我使用 Dimastr 的 Redeption 在 Outlook VBA 中编写了以下代码，尝试设置延迟电子邮件的 SentOn 和 ReceivedTime 属性，因为 Outlook 在您单击“发送”当天设置 ReceivedTime，但在实际发送时不会设置。它基于已发送邮件文件夹上的 ItemAdd 事件。问题是有时它可以正常工作，但有时却不能，尤其是当电子邮件推迟到另一天时，同时我关闭了 Outlook。就像 Redemption 保存调用不起作用或被覆盖一样。您是否做过类似的事情并找到了解决方案？

这是de代码：

Private Sub SentItems_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
  
  Open FILEPATH For Append As 1
  Print #1,Now & " ItemAdd Step 1: " & item.Subject & " : " & item.SentOn & " - " & item.ReceivedTime & " - " & item.DeferredDeliveryTime

  If item.DeferredDeliveryTime <> #1/1/4501# Then
  
    Print #1,Now & " ItemAdd Step 2: " & item.Subject & " : " & item.SentOn & " - " & item.ReceivedTime & " - " & item.DeferredDeliveryTime
  
    If RDOSession Is nothing Then
      Set RDOSession = CreateObject("Redemption.RDOSession")
      RDOSession.MAPIOBJECT = Application.Session.MAPIOBJECT
    End If
   
    Set sitem = RDOSession.GetMessageFromID(item.EntryID)
    sitem.SentOn = Now
    sitem.ReceivedTime = Now
    sitem.DeferredDeliveryTime = #1/1/4501#
    sitem.Save
    
    Print #1,Now & " ItemAdd Paso 3: " & sitem.Subject & " : " & sitem.SentOn & " - " & sitem.ReceivedTime & " - " & sitem.DeferredDeliveryTime
    
    Set sitem = nothing

  End If
  
ProgramExit:
  Close #1
  Exit Sub
ErrorHandler:
  'MsgBox "The following error occurred: " & Err.Description
  Resume ProgramExit
End Sub

提前致谢。

解决方法

尝试替换该行

 Set sitem = RDOSession.GetMessageFromID(item.EntryID)

与

 Set sitem = RDOSession.GetRDOObjectFromOutlookObject(item)

,

商店提供程序将 PR_CLIENT_SUBMIT_TIME (SentOn) 设置为客户端应用程序调用 Send 方法的时间。该问题似乎与 Redemption 库无关。我建议使用 MFCMAPI 应用程序，看看扩展 MAPI 和存储提供程序是如何工作的。