Question

我有一个辅助交换帐户，其中服务器规则处于活动状态，可以将收到的每封邮件转发到我的主帐户（在另一台服务器上）。为了避免无意义的转发标头并保留From和To字段，我将邮件转发为附件和

我对此代码有三个问题并且有点卡住，所以我在这里发布它以希望获得一些输入：

我想运行附件验证，因此只有实际的邮件类型会解压缩到收件箱。我找到了.Type属性，但这只给了我一个数字，我找不到相应的参考。如果找到任何非邮件附件（或没有附件），则应保存或不删除转发邮件。
项目在收件箱中创建为草稿而不是收到的邮件项目。我找不到任何方法来更改文档类型。
好像我的代码在我的发件箱中随机创建了空消息。也许这是因为从磁盘打开消息并且除了移动它之外没有做任何事情，但我现在还不能确定。如果解压缩的消息包含附件，则可以在发件箱中找到带有这些附件的空草稿。

下面我发布了整个代码，主要归功于a related question答案中的信息。

Public Sub unpackAttachedMessage(itm As Outlook.MailItem)


    Dim olApp As New Outlook.Application
    Dim olNameSpace As Outlook.NameSpace
    Dim olTargetFolder As Outlook.Folder
    Dim objAtt As Outlook.Attachment

    ' Program Configuration Variables and Constants
    Const saveFolder As String = "C:\Temp\Outlook"
    Const messageCategory As String = "CategoryName"

    ' Runtime Variables
    Dim i As Integer
    Dim attachmentCount As Integer
    i = 1

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' Folder creation does not seem to work.
    If Not fso.FolderExists(saveFolder) Then
        fso.CreateFolder (saveFolder)
    End If


    ' For each attachment in the message.
    For Each objAtt In itm.Attachments
        ' Save it to disk as a message.
        objAtt.SaveAsFile saveFolder & "\" & i & ".msg"

        ' Retrieve a message from disk.
        Dim message As Outlook.MailItem
        Set message = Application.CreateItemFromTemplate(saveFolder & "\" & i & ".msg")

        ' Modify the Message.
        ' Note that this and potentially other message options need
        '   to be set BEFORE you move the item to its destination folder.
        ' Set the Category.
        message.Categories = message.Categories & "," & messageCategory
        ' Mark as unread.
        message.UnRead = True

        ' MsgBox "Class: " & itm.MessageClass & " --- Attached Item Class: " & message.MessageClass
        ' Doesn't work
        'message.MessageClass = olPostItem

        ' Save changes to the message.
        message.Save

        ' Move the item to Inbox.
        Set olNameSpace = olApp.GetNamespace("MAPI")
        Set olTargetFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
        message.Move olTargetFolder

        ' objAtt.DisplayName
        Set objAtt = Nothing
        i = i + 1
    Next
    attachmentCount = i

End Sub

Answer 1

您可以尝试使用Namespace.OpenSharedItem，但据我所知它会遇到同样的问题。

如果使用Redemption是一个选项，您可以创建一个不会破坏原始邮件的服务器端委托规则（http://www.dimastr.com/redemption/rdoruleactions.htm，您将需要重定向操作）。

要提取嵌入式邮件附件，您可以使用RDOAttachment。EmbeddedMsg属性（返回RDOMail对象）。您应该能够将该邮件复制到任何文件夹。沿着这条线（我的头顶）：

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
set rdoMsg = Session.GetRDOObjectFromOutlookObject(itm)
set Inbox = Session.GetDefaultFolder(olFolderInbox)
For Each objAtt In rdoMsg.Attachments
  if objAtt.Type = olEmbeddedItem Then 
    set newmsg = Inbox.Items.Add("IPM.Note")
    newmsg.Sent = true 'must be set before Save is called for the first time
    objAtt.EmbeddedMsg.CopyTo(newmsg)
    newmsg.Save
  End If
next

Answer 2

感谢在此处回答和评论的人员的输入，我现在有了一个有效的VBA功能，可以将MailItem的所有邮件附件解压缩到收件箱。它还添加了一个类别并将其标记为未读。这通过在Outlook.Application中的MAPI命名空间中使用OpenSharedItem方法来工作。完整的VBA代码可以在下面找到。我已经在在线论坛上看到过这种情况，所以我希望这对其他人也有用。

' This program moves all message attachments for the handled MailItem to the inbox, adds a category and marks them as unread.
Public Sub unpackAttachedMessage(itm As Outlook.MailItem)

    Dim olApp As New Outlook.Application
    Dim olNameSpace As Outlook.NameSpace
    Dim objAtt As Outlook.Attachment
    Dim message As Outlook.MailItem
    Dim myCopiedItem As Outlook.MailItem

    ' Program Configuration Variables and Constants
    Const saveFolder As String = "C:\Temp\Outlook"
    Const messageCategory As String = "Category"

    Set olNameSpace = olApp.GetNamespace("MAPI")

    ' Create the temporary save folder if it does not exist.
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(saveFolder) Then
        fso.CreateFolder (saveFolder)
    End If

    ' Runtime Variables
    Dim i As Integer
    i = 1

    ' For each attachment in the MailItem.
    For Each objAtt In itm.Attachments

        ' If it's a message type,
        If objAtt.Type = olEmbeddeditem And Right(objAtt.FileName, 4) = ".msg" Then

            ' Save it to disk,
            objAtt.SaveAsFile saveFolder & "\" & i & ".msg"

            ' Read it from disk as a Shared Item,
            Set message = olNameSpace.OpenSharedItem(saveFolder & "\" & i & ".msg")

            ' Set the Category,
            message.Categories = message.Categories & "," & messageCategory
            ' Mark it as Unread,
            message.UnRead = True

            ' and Move it to the Inbox by creating a copy.
            Set myCopiedItem = message.Copy
            message.Delete

            ' Clear the references
            Set message = Nothing
            Set myCopiedItem = Nothing
            Set objAtt = Nothing

            ' and remove the files from disk.
            Kill (saveFolder & "\" & i & ".msg")
        End If
        i = i + 1
    Next

End Sub

请注意，此代码仅解包邮件附件并忽略其他所有内容。我个人在一个规则中运行它，该规则针对特定的仅向前帐户运行并且perma-删除每个处理过的消息，但请注意，在这种情况下，您不要丢弃任何合法邮件。如果您愿意，可以通过指定收件箱以外的文件夹来移动它来改进此代码。

Answer 3

在此解决方案中，您丢失了一些标题信息，但它不需要兑换。

Sub test()
Dim path As String
Dim olApp As Outlook.Application
Dim olitem As Outlook.MailItem
Dim olfolder As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olitem = Application.ActiveInspector.CurrentItem
Set olfolder = GetFolder(olitem.Parent.folderPath)
path = "c:\test\"

For Each objAtt In olitem.Attachments
  If objAtt.Type = olEmbeddeditem And Right(objAtt.FileName, 3) = "msg" Then
     objAtt.SaveAsFile path & "\" & objAtt.FileName
     Set objFile = olApp.CopyFile(path & "\" & objAtt.FileName, olfolder)
    Kill path & "\" & objAtt.FileName
  End If
Next
End Sub

Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' strFolderPath needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales" or
  '   "Personal Folders\Inbox\My Folder"
  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim i As Long
 ' On Error Resume Next

  strFolderPath = Replace(strFolderPath, "\\", "")
  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = Application
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For i = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(i))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function

自动解压缩附加的消息

3 个答案: