くのへスタジオ こんにちは、くのへ@MasazaneKunoheです。
こんなツイート頂きました。
これはちょっと作ってみるしかない！！😀
まずはエクセル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これを実行するとこのようになります
さらに改造したコード
さらにこんなツイート頂きました
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
解説はコードの中に書いたので、ある程度 読み解けるかな～と思います。（ニーズがあったら書きます～）
ではまた別の記事で～
🦅バサバサ～
