0

受信したすべてのメールをプライマリ アカウント (別のサーバー上) に転送するサーバー ルールが有効になっているセカンダリ Exchange アカウントがあります。無意味な転送ヘッダーを回避し、From フィールドと To フィールドを保持するために、メールを添付ファイルとして転送し、

このコードには 3 つの問題があり、少し行き詰っています。そのため、ここに投稿して、何らかの情報を得られることを願っています。

  • 添付ファイルの検証を実行して、実際のメッセージ タイプのみが受信トレイに展開されるようにしたいと考えています。プロパティは見つかりました.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 に答える