自动解包附加消息 [英] Automatically Unpack Attached Messages

问题描述

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

I have a secondary exchange account where a server rule is active that forwards every mail it receives to my primary account (on another server). To avoid pointless forwarding headers and to preserve the From and To fields, I forward mails as an attachment and

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

I have three issues with this code and am a bit stuck, so I'm posting it here to hopefully get some input:

• 我想运行附件验证，所以只有实际的邮件类型被打包到收件箱。我找到了 .Type 属性，但这只给我一个数字，我找不到相应的引用。如果发现任何非邮件附件（或没有附件），转发邮件应该保存或不被删除。


• 项目在收件箱中创建为草稿，而不是收到的邮件项目。我找不到任何方法来更改文档类型。


• 看起来我的代码在我的发件箱中随机创建了空的消息。也许这是因为打开了磁盘的消息，并没有做任何事情，除了移动它，但我现在不能确定。如果已解压缩的邮件有附件，则可以在发件箱中找到带有这些附件的空白草稿。

• I'd like to run attachment validation so only actual message types are unpacked to the Inbox. I've found the .Type property but this only gives me a number and I can't find the corresponding reference. If any non-message attachments (or no attachments) are found, the forwarding message should be saved or not deleted.
• Items are created in the Inbox as drafts instead of received mail items. I can't find any way to change the document type.
• It seems like my code randomly creates empty messages in my Outbox. Perhaps this is due to opening the message from disk and not doing anything with it apart from moving it, but I can't really be sure right now. If an unpacked message has attachments, an empty draft with those attachments can be found in the Outbox.

以下我已经发布了整个代码，主要得益于相关问题的答案的信息。

Below I've posted the entire code, created largely thanks to information from an answer to 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

推荐答案

感谢在这里回答和评论的人的投入，我现在有一个工作的VBA功能来解包所有的邮件附件用于邮箱到收件箱。它还添加一个类别并将其标记为未读。这可以通过在Outlook.Application中的MAPI命名空间中使用OpenSharedItem方法来实现。完整的VBA代码可以在下面找到。我已经看过这个在线论坛提出了好几次，所以我希望这对别人也有用。

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.

这篇关于自动解包附加消息的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！