質問: Outlookを使用しており、作業の効率化を図るためにVBAを使用したいです。 下記イメージなのですが、作成は可能なのでしょうか・・・ 【指定フォルダ or 指定件名を含むメールの本文内の画像をエクセルに貼り付け】 複数人からiPhoneのメールで送られてくる画像を1クリックでエクセルにまとめて貼り付けしたいです
回答: > >【指定フォルダ or 指定件名を含むメールの本文内の画像をエクセルに貼り付け】 > >複数人からiPhoneのメールで送られてくる画像を > >1クリックでエクセルにまとめて貼り付けしたいです > > Outlook VBA で メールに添付された写真をExcelに貼る 処理のイメージがあっているか、わからないが、 下記の用に作成してみました ← テスト動画です、参考になれば。 !D ``` '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やキャリアのメールで送られた場合のテスト・・・など。 など、いろいろと課題や積み残しがありますが、 たたき台のサンプルとして活用できれば幸いです。