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

こんなツイート頂きました。

ツールの仕様は
受信メールの情報をExcelに転記されていて、添付ファイルがほしいメールにだけチェックを入れる

チェックが入ったメールの添付ファイルのみダウンロードする

このチェックが入ったメールをOutlook探すときにEntryID使い一発で探したい
— かおてっく (@Kao_Tech_) July 23, 2021

これはちょっと作ってみるしかない！！😀

まずはエクセルVBAで受信メールボックスの中身を書き出す

①次のようなエクセルを準備してください

B2セルには、添付資料を保存したいフォルダの絶対アドレスを記入します。

②エクセルでOutlookの参照設定を行った上で、次のコードをエクセルVBAに記述します。
参照設定方法はこちらを参照

↓コピペで動くと思います（エクセルVBAに記述）

Sub メール一式抽出()

'appOLを呼び出す
  Dim appOL As Outlook.Application
  Set appOL = New Outlook.Application

'セルに受信メールを書き出す
  Dim objMailItems As Object
  Dim objMailItem As Object
  Dim i As Integer
  i = 4
  
  Set objMailItems = appOL.getnamespace("MAPI").getdefaultfolder(6).Items

  For Each objMailItem In objMailItems
  
    With objMailItem
      
    '主要項目の書き出し
      Cells(i, 2).Value = .Subject      '件名
      Cells(i, 3).Value = .ReceivedTime '受信日
      Cells(i, 4).Value = .SenderName   '送信者メアド
      
    '添付資料の有無も書き出す
      If .Attachments.Count <> 0 Then
        Cells(i, 5).Value = "有"
      Else
        Cells(i, 5).Value = "無"
      End If
      
    'EntryIDも書き出す
      Cells(i, 6).Value = .EntryID
    
    End With
    
    i = i + 1
  
  Next objMailItem

'オブジェクトをNothingしておく
  Set appOL = Nothing
  Set objMailItems = Nothing
  Set objMailItem = Nothing

End Sub

これを実行すると、受信フォルダのメールの件名、受信日、送信者、添付資料の有無、EntryIDをそれぞれ書き出すことができます。

③次に、添付ファイルを抽出したいメールのA列に「１」と書きます。これでフラグが立ち、そのメールの添付資料だけが抽出されます。
　ちなみに「１」でなくても、空欄以外なら何でもOKです。

④そして、次のコードを実行します（コピペで動くと思います）

Sub メール添付資料抽出()

'appOLを呼び出す
  Dim appOL As Outlook.Application
  Set appOL = New Outlook.Application

'保存先のアドレスを読み込む。最後に\マークも加筆しておく

  Dim strFolderPath As String
  strFolderPath = Cells(1, 2).Value & "\"

'受信ボックスを呼び出す。ForEach文用のオブジェクト変数も定義しておく
  Dim objMailItems As Object
  Dim objMailItem As Object
  
  Set objMailItems = appOL.getnamespace("MAPI").getdefaultfolder(6).Items

'FSOも使えるようにしておく
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")


'1列目が空欄ではないメールの添付資料を抽出。
  Dim i As Integer: i = 4  'エクセル 行制御用変数
  Dim objAttachment As Object 'メール添付資料抽出用オブジェクト変数
  Dim strFileName As String '添付資料の名前設定用変数
  Dim j As Integer  '添付資料の名前が重複した時に通し番号を振るための変数
  Dim strCheckFileName As String
  
  '埋め込み画像は添付資料として抽出しないようにProptagを使う
  Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"


  Do Until Cells(i, 2).Value = ""
  
  '1列目が空欄ではない行を対象にする
    If Cells(i, 1).Value <> "" Then
    
      For Each objMailItem In objMailItems
      
        With objMailItem
          
          'EntryIDが同じメールを対象とする
          If .EntryID = Cells(i, 6).Value Then
            
            'フォルダを作る
            objFSO.CreateFolder strFolderPath & Format(objMailItem.ReceivedTime, "yyyymmdd") & .Subject
                      
            'メールのすべての添付資料を抽出する
            For Each objAttachment In .Attachments
            
              'ただし、埋め込み画像は保存しないようにするif文を記述（呪文と思ってOK）
              If objAttachment.Type <> 6 And _
                (objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID) = "" Or _
                Right(objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID), 11) = "outlook.com") Then
                 
                '添付資料の名前を設定
                strFileName = strFolderPath & Format(objMailItem.ReceivedTime, "yyyymmdd") & .Subject & "\" & objAttachment
                
              'ここから同じ名前のファイルが無いかチェック
                'チェック用変数にファイル名を入れる
                strCheckFileName = strFileName
                
                '添付資料の名前が重複したら番号を振るための変数に初期値代入
                j = 1
                
                'ファイル名が重複したら拡張子の前に通し番号を入れる
                Do While Dir(strCheckFileName) <> ""
                  strCheckFileName = Replace(strFileName, Mid(strFileName, InStrRev(strFileName, ".")), "") & "(" & i & ")" & Mid(strFileName, InStrRev(strFileName, "."))
                  j = j + 1
                Loop
              
                '添付ファイルを保存
                objAttachment.SaveAsFile strCheckFileName
          
              End If
          
            Next objAttachment
            
          End If
           
        End With
          
      Next objMailItem
        
    End If
    
    i = i + 1
  
  Loop


'オブジェクトをNothingしておく
  Set appOL = Nothing
  Set objMailItems = Nothing
  Set objMailItem = Nothing
  Set objFSO = Nothing
  Set objAttachment = Nothing

End Sub

これを実行するとこのようになります

さらに改造したコード

さらにこんなツイート頂きました

にわとりさんから頂いたこちらも試してみようとおもいます！
やっぱりVBAer鳥キャラ強し！ https://t.co/qWGeulTOgH
— かおてっく (@Kao_Tech_) July 23, 2021

GetItemFromIDメソッド！！！
これは全く閃きませんでしたｗ

これを使って添付資料を２つ目のコードを書き換えるとこんな感じにコンパクトにできました。

Sub メール添付資料抽出2()

'appOLを呼び出す
  Dim appOL As Outlook.Application
  Set appOL = New Outlook.Application

'保存先のアドレスを読み込む。最後に\マークも加筆しておく

  Dim strFolderPath As String
  strFolderPath = Cells(1, 2).Value & "\"

'FSOも使えるようにしておく
  Dim objFSO As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")


'1列目が空欄ではないメールの添付資料を抽出。
  Dim i As Integer: i = 4  'エクセル 行制御用変数
  Dim objAttachment As Object 'メール添付資料抽出用オブジェクト変数
  Dim strFileName As String '添付資料の名前設定用変数
  Dim j As Integer  '添付資料の名前が重複した時に通し番号を振るための変数
  Dim strCheckFileName As String
  
  Dim objMailItem As Object 'GetItemFromIDメソッドでEntryIDからメールアイテムを抽出する
  
  '埋め込み画像は添付資料として抽出しないようにProptagを使う
  Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"


  Do Until Cells(i, 2).Value = ""
  
  '1列目が空欄ではない行を対象にする
    If Cells(i, 1).Value <> "" Then
  
  'EntryIDからメールを抽出
      Set objMailItem = appOL.getnamespace("MAPI").GetItemFromID(Cells(i, 6))
    
      With objMailItem
        'フォルダを作る
        objFSO.CreateFolder strFolderPath & Format(objMailItem.ReceivedTime, "yyyymmdd") & .Subject
                      
        'メールのすべての添付資料を抽出する
        For Each objAttachment In .Attachments
            
          'ただし、埋め込み画像は保存しないようにするif文を記述（呪文と思ってOK）
          If objAttachment.Type <> 6 And _
            (objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID) = "" Or _
            Right(objAttachment.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID), 11) = "outlook.com") Then
                 
            '添付資料の名前を設定
            strFileName = strFolderPath & Format(objMailItem.ReceivedTime, "yyyymmdd") & .Subject & "\" & objAttachment
                
        'ここから同じ名前のファイルが無いかチェック
            'チェック用変数にファイル名を入れる
            strCheckFileName = strFileName
                
            '添付資料の名前が重複したら番号を振るための変数に初期値代入
            j = 1
                  
            'ファイル名が重複したら拡張子の前に通し番号を入れる
            Do While Dir(strCheckFileName) <> ""
              strCheckFileName = Replace(strFileName, Mid(strFileName, InStrRev(strFileName, ".")), "") & "(" & i & ")" & Mid(strFileName, InStrRev(strFileName, "."))
              j = j + 1
            Loop
              
            '添付ファイルを保存
            objAttachment.SaveAsFile strCheckFileName
          
          End If
          
        Next objAttachment
           
      End With
                  
    End If
    
    i = i + 1
  
  Loop


'オブジェクトをNothingしておく
  Set appOL = Nothing
  Set objMailItem = Nothing
  Set objFSO = Nothing
  Set objAttachment = Nothing

End Sub

解説はコードの中に書いたので、ある程度読み解けるかな～と思います。（ニーズがあったら書きます～）
ではまた別の記事で～
🦅バサバサ～

くのへスタジオはこちら。
Outlook-VBAコーナーはこちら。