0

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

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

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

下面我发布了整个代码，主要归功于相关问题的答案中的信息。

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
4

3 回答 3

2

您可以尝试使用 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
于 2013-10-23T15:14:19.273 回答
1

Thanks to the input of the people who answered and commented here, I now have a working VBA function that unpacks all message attachments for a MailItem to the Inbox. It also adds a category and marks them as unread. This works by using the OpenSharedItem method in the MAPI Namespace in Outlook.Application. The full VBA code can be found below. I've seen this brought up several times in online fora so I hope this will be useful to others as well.

' 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

Note that this code only unpacks message attachments and ignores everything else. I personally run it in a rule that runs for specific forward-only accounts and perma-deletes every handled message, but take care that you don't throw away any legitimate mails in this case. This code could probably be improved by specifying a folder other than the Inbox to move it to, if you so desire.

于 2013-10-28T14:09:58.503 回答
0

在此解决方案中，您丢失了一些标头信息，但它不需要赎回。

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
于 2013-10-23T17:04:23.643 回答