こんにちは、くのへ@MasazaneKunoheです。

前回にこんなツイート頂きました～

002 続 Outlook メール本体と添付資料を一発保存マクロ完全版｜くのへスタジオ https://t.co/88zQ8hmrDv

今日レザードのこのマクロを使ったんだけど、サクッと保存されてめちゃ便利だったー✨☺️
署名に宣伝用の画像とか貼ってる人がいるとその画像も保存しちゃうのが…😭(私も方針で貼らされてる)
— しるる (@sirururun) April 8, 2021

これはつまり、「埋め込み画像」まで添付資料として保存されるのは邪魔ぁ、ということだね！！

これ、がっつり調べて実装出来ました！！

メール本体と添付資料を一発で保存

コードの機能はこんな感じです

① Outlookの受信ボックスでメールを選択している状態でこのマクロを動かすと、デスクトップにフォルダができてメール本体と添付資料が保存されます。

②ただし、この保存する添付資料に埋め込み画像は含めません。

③デスクトップに作成されるフォルダ名は、ダイヤログボックスで入力するようにしています。名前を入力すると、今日の日付＋名前（入力値）のフォルダが生成されます。メールの受信日や送信日ではなく、実際にマクロを実行した日が書かれます

④メール本体の名前も②で入力した名前になります。

コード

コピペで動くと思います。

Sub 改_受信BOXでメール保存()
  
'受信ボックスで選択している1番目のメールを抽出する
  
  Dim objSelect As Outlook.Selection
  Dim objItem As Object
  Set objSelect = Outlook.Application.ActiveExplorer.Selection
  Set objItem = objSelect.Item(1)
    
'デスクトップのアドレスを取得
  Dim wsh As Object
  Dim strPath As String
  
  Set wsh = CreateObject("WScript.Shell")
  strPath = wsh.SpecialFolders(4) & "\"
    
'フォルダ名＆メール名をダイヤログボックスで取得
  Dim strName As String
  strName = InputBox("フォルダ名を記載ください", "フォルダ作成", "フォルダ名")
  If StrPtr(strName) = 0 Then Exit Sub  'キャンセル時にマクロ終了
  strName = Left(Date, 4) & Mid(Date, 6, 2) & Mid(Date, 9, 2) & "_" & strName

'フォルダを作ってメール本体を保存する
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  objFSO.CreateFolder strPath & strName
  
  objItem.SaveAs strPath & strName & "\" & strName & ".msg"

'objItemに入っている添付資料をフォルダに保存する
  Dim objAttachment As Object
  Dim strFile As String
  Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"


  With objItem
    For Each objAttachment In .Attachments
        If objAttachment.Type <> 6 And _
        objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID) = "" Then
            strFile = strPath & strName & "\" & objAttachment
            objAttachment.SaveAsFile strFile
        End If
    Next objAttachment
  End With
  
  '各オブジェクト達をNothingで消しておく
  Set objSelect = Nothing
  Set objItem = Nothing
  Set wsh = Nothing
  Set objFSO = Nothing
  Set objAttachment = Nothing


End Sub

動作の動画

動かしてみたところがこちらです。

埋め込み画像は保存されていないことが分かります！！😆キター

解説

前回のコードの下の部分に、赤字のコードを追加しました。


'objItemに入っている添付資料をフォルダに保存する
  Dim objAttachment As Object
  Dim strFile As String
  Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"


  With objItem
    For Each objAttachment In .Attachments
        If objAttachment.Type <> 6 And _
        objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID) = "" Then
            strFile = strPath & strName & "\" & objAttachment
            objAttachment.SaveAsFile strFile
        End If
    Next objAttachment
  End With

これは、objAttachment＝埋め込み画像、だった場合に次のような方法で対象外にするコードです。

－メールが「リッチテキスト」形式の場合は、添付資料オブジェクトが埋め込み画像だった場合、オブジェクトのtypeプロパティが「olOLE」というタイプになるという特性を使っています。
　olOLEを表すシリアル番号が「６」だったので、6以外ならOKというコードにしています。

－メールが「HTML」形式の場合は、、、これはプロパティでは分類できませんでした。
　そこで調べまくった結果、PropertyAccessor.GetPropertyというメソッドで、
　名前空間(:特定のURLのようなコード)を使ってプロパティ風に調べられるという方法にたどり着きました。

　PropertyAccessor.GetPropertyというメソッドの書式はこちら↓
　　PropertyAccessor.GetProperty（名前空間）

　これを書き込むことで、プロパティのような値を得ることが出来ます。

　ここで、名前空間に『“http://schemas.microsoft.com/mapi/proptag/0x3712001F”』を代入して、
　　objAttachment.PropertyAccessor.GetProperty(名前空間)
　というコードを描くと、objAttachmentの中身が埋め込み画像ならば「image001.png@01D7XXX.064XXXXXX」という体裁の値が返ってきます。
　一方、埋め込み画像でなければ「」（無）が返ってきます。
　この特性を使って、埋め込み画像かどうかを判別させています。

　これはなかなか高難度だった。