Outlook VBA 添付ファイル写真の取り出しはてなの質問にチャレンジしてみた。テストしてみた

はてなの質問
q.hatena.ne.jp
にチャレンジしてみた。テストしてみた

＞【指定フォルダ or 指定件名を含むメールの本文内の画像をエクセルに貼り付け】
＞複数人からiPhoneのメールで送られてくる画像を
＞1クリックでエクセルにまとめて貼り付けしたいです

Outlook VBA でメールに添付された写真をExcelに貼る

処理のイメージがあっているか、わからないが、
下記の用に作成してみました

https://www.youtube.com/watch?v=SF9w8ILrO1Q ← テスト動画です、参考になれば。

'Outlook で　メールに添付された写真をExcelに貼る
'サブフォルダ ここでは 写真テスト 固定です の 受信メール読み込むサンプル
'件名と添付ファイル名(複数)を取り出す(表示する)
'添付ファイルを固定の D:\VBA\ に書き出すテスト
'新規起動したExcelブック・シートに書き込むテスト
Sub outlook_test20190522_003()

'Excel 起動処理
    Dim objEXCEL As Excel.Application 'アプリケーションを入れる箱

    Set objEXCEL = CreateObject("Excel.Application") 'エクセルのアプリケーションを作る
    objEXCEL.Visible = True      '可視、見えるようにする。お約束／呪文？
    objEXCEL.UserControl = True  'マクロ終了後、ユーザー操作可能とする。※最近見かけないのでなくていいかも
    
    objEXCEL.Workbooks.Add  '新規のブック作成
    objEXCEL.Sheets.Add     '新規のシート追加

'サブフォルダからメールを読み込みながら、Excelへ添付画像を貼り付ける
    Dim oNamespace As NameSpace
    Dim oFolder As Outlook.Folder 'フォルダー
    
    ' NameSpace オブジェクトへの参照を取得します。
    Set oNamespace = Application.GetNamespace("MAPI")

    ' 既定のフォルダへの参照を取得し、フォルダを表示します。
    Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox) '受信トレイを指定
    oFolder.Display   '選択したフォルダーの表示

    Dim mITEM       As Outlook.MailItem    'メールアイテム
    Dim oAttachment As Outlook.Attachment  'Attachment 添付 アタッチメント
    Dim n As Integer  'n件目の写真
    Dim yROW As Integer  'セットする行数

    'テストで名前の表示
    Debug.Print oFolder.Name

    n = 0  '処理件数の初期化
    'メールアイテムの処理 サブフォルダーを.Folders("写真テスト").Itemsで指定
    For Each mITEM In oFolder.Folders("写真テスト").Items  'アイテム数分ループ
        '↑代入が終わったので、各プロパティに mITEM.XXXX で アクセスする
        
        'デバッグでイミディエイトに表示
        Debug.Print "件名:" & mITEM.Subject '件名表示
        'MsgBox "件名:" & mITEM.Subject & "処理"
        
        '添付ファイルの処理 ※添付ファイルは複数あるよ
        For Each oAttachment In mITEM.Attachments 'メールの添付複数.Attachments
            '添付ファイルのファイル名が、 oAttachment.FileNameでわかります。
            Debug.Print ".FileName " & oAttachment.FileName
            '拡張子が.jpgだけ処理します
            If Right(oAttachment.FileName, 4) = ".jpg" Or Right(oAttachment.FileName, 4) = ".JPG" Then
                'Dドライブの固定フォルダ D:\VBA\ に テストで保存してます
                '自分の環境で、テンポラリのフォルダを作ってください
                oAttachment.SaveAsFile "d:\VBA\" & oAttachment.FileName
                '↑.SaveAsFile "ドライブ:\フォルダー\ファイル名.xxx" で書き込めます
                '↑で、書き込んだファイルをExcel↓で読み込みます
                DoEvents
                yROW = n * 50 + 1  'セットする行位置 ※1 苦肉の策で50行単位にセット改善する
                objEXCEL.Cells(yROW, 1) = "件名:" & mITEM.Subject '件名セット
                objEXCEL.Cells(yROW + 1, 1).Select  '写真のセット位置
                '保存されたファイル名の写真を挿入する。
                objEXCEL.ActiveSheet.Pictures.Insert ("d:\VBA\" & oAttachment.FileName)
                objEXCEL.Cells(yROW, 1).Select
                
                '※2 ここで.jpgファイルを消す処理を入れないと、処理済みのゴミがたまるかな
                
                n = n + 1  '最後に処理件数を増やす
            End If
        Next
        
        Debug.Print ""
    Next

    '使用したオブジェクトの解放　= Nothing
    Set mITEM = Nothing
    
    Application.ActiveExplorer.Close   '新しく開いてしまったフォルダーを閉じる
    Set oFolder = Nothing
    Set oNamespace = Nothing

End Sub

やり残しと改善点？

※1
写真をセットする行位置を
写真の挿入(貼り付け)後の行数・大きさがわからなかったので、
苦肉の策で50行単位にセットしてます。
※行数は、わかるはずなので、きれいにセットするように変更する？

※2
添付ファイルをD:\VBAに保存して使っているが、
.jpgファイルを消す処理を入れないと、
処理済みのゴミがたまる

※3
処理済みのメールを移動させた方が便利かも
受信指定サブフォルダーから添付写真を取り出したら、
処理済みなどのフォルダーに移動したほうが便利かも？

※4
Outlook VBA から Excel を起動しているが、
逆の Excel VBAからOutlookを読みに行った方がいいのかなぁ？
※Excel VBAにして、取り込みボタンを作成したほうがいいのかなあ？

※5
iPhoneのメール gmailやキャリアのメールで送られた場合のテスト・・・など。

など、いろいろと課題や積み残しがありますが、
たたき台のサンプルとして活用できれば幸いです。

受信トレイサブフォルダーのメールを処理
ken3memo.hatenablog.com
を参考にして、

'サブフォルダ ここでは 写真テスト 固定です の 受信メール読み込むサンプル
'件名と添付ファイル名(複数)を取り出す(表示する)
'添付ファイルを固定の D:\VBA\ に書き出すテスト
Sub outlook_test20190522_001()

    Dim oNamespace As NameSpace
    
    Dim oFolder As Outlook.Folder 'フォルダー
    
    ' NameSpace オブジェクトへの参照を取得します。
    Set oNamespace = Application.GetNamespace("MAPI")

    ' 既定のフォルダへの参照を取得し、フォルダを表示します。
    Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox) '受信トレイを指定
    oFolder.Display   '選択したフォルダーの表示

    Dim mITEM       As Outlook.MailItem    'メールアイテム
    Dim oAttachment As Outlook.Attachment  'Attachment 添付 アタッチメント
    
    'テストで名前の表示
    Debug.Print oFolder.Name

    'フォルダーの下には サブフォルダーとアイテムが存在します

    'メールアイテムの処理 サブフォルダーを.Folders("写真テスト").Itemsで指定
    For Each mITEM In oFolder.Folders("写真テスト").Items  'アイテム数分ループ
        '↑代入が終わったので、各プロパティに mITEM.XXXX で アクセスする
        MsgBox "件名:" & mITEM.Subject & "を処理します" '件名表示
        
        'デバッグでイミディエイトに表示
        Debug.Print "件名:" & mITEM.Subject '件名表示
        
        '添付ファイルの処理 ※添付ファイルは複数あるよ
        For Each oAttachment In mITEM.Attachments 'メールの添付複数.Attachments
            '添付ファイルのファイル名が、 oAttachment.FileNameでわかります。
            Debug.Print ".FileName " & oAttachment.FileName
            'Dドライブの固定フォルダ D:\VBA\ に テストで保存します
            oAttachment.SaveAsFile "d:\VBA\" & oAttachment.FileName
            '↑.SaveAsFile "ドライブ:\フォルダー\ファイル名.xxx" で書き込めます
        Next
        
        Debug.Print ""
    Next

    '使用したオブジェクトの解放　= Nothing
    Set mITEM = Nothing
    
    Application.ActiveExplorer.Close   '新しく開いてしまったフォルダーを閉じる
    Set oFolder = Nothing
    Set oNamespace = Nothing

End Sub

をテスト作成

Outlook から Excelを起動する処理は
ken3memo.hatenablog.com
を参考にして、

'outlookからExcelを起動して 新規ブックの作成テスト
Sub outlook_test20190522_002()

    Dim objEXCEL As Excel.Application 'アプリケーションを入れる箱

    Set objEXCEL = CreateObject("Excel.Application") 'エクセルのアプリケーションを作る
    objEXCEL.Visible = True      '可視、見えるようにする。お約束／呪文？
    objEXCEL.UserControl = True  'マクロ終了後、ユーザー操作可能とする。※最近見かけないのでなくていいかも
    
    objEXCEL.Workbooks.Add  '新規のブック作成
    objEXCEL.Sheets.Add     '新規のシート追加

End Sub

をテスト作成

三流君 ken3のmemo置き場

三流プログラマーのメモ書きです。主にVBAやWindowsの話題が多いです

Outlook VBA 添付ファイル写真の取り出しはてなの質問にチャレンジしてみた。テストしてみた

Ken3 ホームページ目次

Ken3 ホームページ 目次

Ken3 ホームページ目次