Sub 受信トレイの添付ファイルを一括保存_期間絞り込み()
Dim olApp As Application
Dim objInbox As Object
Dim objFolder As Object
Dim objItem As Object
Dim objConItems
Dim strPath As String
Dim i As Long
Dim j As Long
Dim strStart As String
Dim strEnd As String
Dim strFileName As String
'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの受信トレイを取得します。
Set olApp = New Outlook.Application
Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set objConItems = objFolder.Items
'添付ファイルの保存先をパスで指定します。
strPath = "F:\test\添付ファイル\"
'開始日と終了日を指定します。
strStart = Format("2022/2/1 00:00", "yyyy/mm/dd hh:nn") '開始日を指定
strEnd = Format("2022/6/16 17:00", "yyyy/mm/dd hh:nn") '終了日を指定
'Restrictメソッドで期間指定して抽出するメールアイテムを絞り込みます。
Set objConItems = objConItems.Restrict("[ReceivedTime] >= '" & strStart & "' And [ReceivedTime] <= '" & strEnd & "'")
'アイテム数分処理を繰り返します。
For Each objItem In objConItems
For i = 1 To objItem.Attachments.Count
'添付ファイル名を変数へ代入します。
strFileName = objItem.Attachments.Item(i)
'添付ファイルに拡張子がある場合のみ処理します。
If InStr(strFileName, ".") <> 0 Then
'ファイルを書き出します。
objItem.Attachments.Item(i).SaveAsFile strPath & objItem.Attachments.Item(i)
End If
Next i
Next objItem
'オブジェクトを解放します。
Set olApp = Nothing
Set objFolder = Nothing
Set objConItems = Nothing
Set objItem = Nothing
MsgBox "Outlook受信トレイの添付ファイル出力が完了しました！", vbInformation
End Sub
Sub 受信トレイの添付ファイルを一括保存_期間絞り込み_上書き回避()
Dim olApp As Application
Dim objInbox As Object
Dim objFolder As Object
Dim objItem As Object
Dim objConItems
Dim strPath As String
Dim i As Long
Dim j As Long
Dim strStart As String
Dim strEnd As String
Dim strFileName As String
'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの受信トレイを取得します。
Set olApp = New Outlook.Application
Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set objConItems = objFolder.Items
'添付ファイルの保存先をパスで指定します。
strPath = "F:\test\添付ファイル\"
'開始日と終了日を指定します。
strStart = Format("2022/2/1 00:00", "yyyy/mm/dd hh:nn") '開始日を指定
strEnd = Format("2022/6/16 17:00", "yyyy/mm/dd hh:nn") '終了日を指定
'Restrictメソッドで期間指定して抽出するメールアイテムを絞り込みます。
Set objConItems = objConItems.Restrict("[ReceivedTime] >= '" & strStart & "' And [ReceivedTime] <= '" & strEnd & "'")
'アイテム数分処理を繰り返します。
For Each objItem In objConItems
For i = 1 To objItem.Attachments.Count
'添付ファイル名を変数へ代入します。
strFileName = objItem.Attachments.Item(i)
'添付ファイルに拡張子がある場合のみ処理します。
If InStr(strFileName, ".") <> 0 Then
'フルパスが存在しない場合のみファイルを書き出します。
If Dir(strPath & strFileName) = "" Then
objItem.Attachments.Item(i).SaveAsFile strPath & strFileName
Else
j = 1
'重複していたら保存ファイル名の先頭に(**)をつけます。
Do While Dir(strPath & strFileName) <> ""
strFileName = "(" & j & ")" & strFileName
j = j + 1
Loop
objItem.Attachments.Item(i).SaveAsFile strPath & strFileName
End If
End If
Next i
Next objItem
'オブジェクトを解放します。
Set olApp = Nothing
Set objFolder = Nothing
Set objConItems = Nothing
Set objItem = Nothing
MsgBox "Outlook受信トレイの添付ファイル出力が完了しました！", vbInformation
End Sub
Sub 受信トレイの添付ファイルを一括保存_期間絞り込み_上書き回避_件名絞り込み()
Dim olApp As Application
Dim objInbox As Object
Dim objFolder As Object
Dim objItem As Object
Dim objConItems
Dim strPath As String
Dim i As Long
Dim j As Long
Dim strStart As String
Dim strEnd As String
Dim strFileName As String
Dim strTokuteiSubject As String
'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの受信トレイを取得します。
Set olApp = New Outlook.Application
Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set objConItems = objFolder.Items
'添付ファイルの保存先をパスで指定します。
strPath = "F:\test\添付ファイル\"
'絞り込みたい件名もしくはキーワードを指定します。
strTokuteiSubject = "【重要】"
'開始日と終了日を指定します。
strStart = Format("2022/2/1 00:00", "yyyy/mm/dd hh:nn") '開始日を指定
strEnd = Format("2022/7/16 17:00", "yyyy/mm/dd hh:nn") '終了日を指定
'Restrictメソッドで期間指定して抽出するメールアイテムを絞り込みます。
Set objConItems = objConItems.Restrict("[ReceivedTime] >= '" & strStart & "' And [ReceivedTime] <= '" & strEnd & "'")
'アイテム数分処理を繰り返します。
For Each objItem In objConItems
For i = 1 To objItem.Attachments.Count
'添付ファイル名を変数へ代入します。
strFileName = "★重要★" & objItem.Attachments.Item(i)
'添付ファイルに拡張子がある場合と特定の件名に合致した場合のみ処理します。
If InStr(strFileName, ".") <> 0 And InStr(objItem.Subject, strTokuteiSubject) <> 0 Then
'フルパスが存在しない場合のみファイルを書き出します。
If Dir(strPath & strFileName) = "" Then
objItem.Attachments.Item(i).SaveAsFile strPath & strFileName
Else
j = 1
'重複していたら保存ファイル名の先頭に(**)をつけます。
Do While Dir(strPath & strFileName) <> ""
strFileName = "(" & j & ")" & strFileName
j = j + 1
Loop
objItem.Attachments.Item(i).SaveAsFile strPath & strFileName
End If
End If
Next i
Next objItem
'オブジェクトを解放します。
Set olApp = Nothing
Set objFolder = Nothing
Set objConItems = Nothing
Set objItem = Nothing
MsgBox "Outlook受信トレイの添付ファイル出力が完了しました！", vbInformation
End Sub
タカヒロ様 迅速なご回答誠にありがとうございます。早速ですが、重複しないvbaを使用させていただきました。が、受信トレイを指定する段階を変更したら、オブジェクトがないとエラーになりました。恐れ入りますが、ご教示いただけますでしょうか。
下記受信トレイを指定したつもりのコードです。
Sub 受信トレイの添付ファイルを一括保存_期間絞り込み_上書き回避()
Dim olApp As Application
Dim objInbox As Object
Dim objFolder As Object
Dim objItem As Object
Dim objConItems
Dim strPath As String
Dim i As Long
Dim j As Long
Dim strStart As String
Dim strEnd As String
Dim strFileName As String
Set objInbox = GetNamespace(“MAPI”).GetDefaultFolder(olFolderInbox)
‘添付ファイルがあるメールのフォルダを指定します。2階層以上ある場合は「.Folders.Item(＜フォルダ名＞)」を追加してください。
Set objFolder = objInbox.Folders.Item(“★★★★サンクスカード集計”)
VBAでOutlookメール本文の一部を抽出しExcelへ出力する方法！
【Outlook VBA】Excelから文字サイズ/色/種類/書式を指定しメールを作成/送信する方法！
【VBA】Excelから複数・多種類のOutlookのメールを作成・送信する方法
Power Appsでメール送信する方法！複数宛先やCC設定も！
【Outlook VBA】転送メールを作成する方法！宛先追加や件名・本文追記も！
VBAでOutlookメール本文の情報をExcelに取り込む方法
【Outlook VBA】受信トレイの添付ファイルを一括保存する方法！期間指定も！
【Outlook VBA】メール本文を改行する方法！改行されない対処法も！
VBA始めたての初心者です。
コメント失礼します。
本章のコードを2階層目のサブフォルダを指定し、実行したところエラーが出てしまいした。
Set objConItems = objConItems.Restrict(“[ReceivedTime] >= ‘” & strStart & “‘ And [ReceivedTime] <= '" & strEnd & "'")
の部分が黄色くなり、438のエラーが出たのですが、考えられる要因を教えていただきたいです。
いつもご利用ありがとうございます。
エラー438ですと、存在しないプロパティを踏んでいる可能性がありますので、
デバッグして取得したアイテムに[ReceivedTime]プロパティが含まれているかご確認いただけますでしょうか。
エラー438の原因と対処法はこちらの記事にまとめておりますので、こちらもご参考ください。
https://extan.jp/?p=3111
よろしくお願いいたします。
タカヒロさま
ご回答ありがとうございました。
受信トレイ配下のサブフォルダであれば可能との回答でしたが、新しいアイテムで作成した【個人用Outlookデータファイル.pst】の下に作成したファルダの指定は難しいでしょうか。
指定フォルダ：>個人用Outlookデータファイル > 受信トレイ > 01)Folder > 01)subFolder
>個人データ
>受信トレイ
>下書き
>送信済みアイテム
>削除済みアイテム
>会話履歴
>個人用Outlookデータファイル【C:\Users\Default\Documents\Outlook ファイル\個人用 Outlook データ ファイル.pst】
>受信トレイ
>01)Folder
>01)subFolder
>02)Folder
>03)Folder
受信したメールを仕分けルールで個人用Outlookデータファイルに移動させてしまっているため、この配下にある指定フォルダに振分けされたメールの添付ファイルを指定フォルダに保存したく、改めて質問させて頂きます。
可能であれば、再度、ご教授を頂きたく、お手数をお掛け致しますがよろしくお願い致します。
アタッチした【個人用Outlookデータファイル.pst】の下のフォルダのアイテム取得につきまして、
GetDefaultFolderメソッドでは対象から外れるため、取得はできません。
なお、こちらのページで紹介しております「【裏技】ローカルユーザーでも共有の連絡先を取得する方法」の
Outlookフォルダチェッカーで各フォルダの位置番号が取得できれば、アイテムの取得ができる可能性があるため、
よろしければ試していただけますでしょうか。
https://extan.jp/?p=6621#Step1%EF%BC%9A%E3%83%A6%E3%83%BC%E3%82%B6%E3%83%BC%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80%E3%81%AE%E4%BD%8D%E7%BD%AE%E7%95%AA%E5%8F%B7%E3%82%92%E7%A2%BA%E8%AA%8D%E3%81%99%E3%82%8B
Outlook VBA始めたばかりです。
本章のVBAで、個人データ(データファイル)の下の指定フォルダに振分けされたメールの添付ファイルを指定フォルダに保存したいのですが、個人データの下の指定フォルダを設定することは可能でしょうか。
いつもご利用ありがとうございます。
個人データの下の指定フォルダに振分けされたメールの添付ファイルを指定フォルダに保存する件ですが、
受信トレイ配下のサブフォルダであれば対応可能です。
サブフォルダの指定方法はこちらをご参考ください。
https://extan.jp/?p=7445#%E3%82%B5%E3%83%96%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80%E3%81%AB%E3%81%82%E3%82%8BOutlook%E5%8F%97%E4%BF%A1%E3%83%A1%E3%83%BC%E3%83%AB%E4%B8%80%E8%A6%A7%E3%82%92Excel%E3%81%AB%E5%8F%96%E3%82%8A%E8%BE%BC%E3%82%80VBA
タカヒロさま
ご回答ありがとうございました。単純に回避することは難しいこと、理解しました。回避策もありがとうございます。今回は一度に同名のファイルをかなりの数一括で保存するのですが、受信日時がバラバラなので、ファイル名に受信日時を追加することで回避することにします。お手数おかけして申し訳ありませんでした。ありがとうございました。今後も応援しております。
タカヒロさま
添付ファイを保存することはできたのですが、ファイル名が「(1)●●」「(1)(2)●●」「(1)(2)(3)●●」「(1)(2)(3)(4)●●」とどんどん増えていってしまいます。サンプルコードをほぼ変えていないのですが、考えられる原因や対処法など御教示いただけないでしょうか。
いつもご利用ありがとうございます。
ファイルが増えてしまう現象について、上書きしない設定となっているため、
同じファイル名がある状態で実行を繰り返すと仕様上リネームされファイルが増える形になります。
回避策としては、出力されたファイルすべてを別の場所に移動するか、削除をしてから
マクロ実行頂きたくお願いいたします。
タカヒロ様 迅速なご回答誠にありがとうございます。
時間がかかるとのこと、了承いたしました。毎月300件以上の添付ファイルを毎回メールを開いて、保存していたため効率化できて本当に助かりました。
ありがとうございました。
タカヒロ様 大変失礼いたしました。日付を設定しておりませんでした。
この日付なんですが、設定しない場合はその日付部分を削除すれば、マクロ実行をする段階ですべてのファイルに対して稼働いたしますでしょうか。たびたびの質問で大変恐縮です。なにとぞよろしくお願いいたします。
日付の設定が影響していたこと了解いたしました。
期間フィルタを外す場合は
以下のコードを削除するかコメントアウトし無効化してください。
‘Restrictメソッドで期間指定して抽出するメールアイテムを絞り込みます。
Set objConItems = objConItems.Restrict(“[ReceivedTime] >= ‘” & strStart & “‘ And・・・
その場合には全期間が対象となりますので、処理時間がかかってしまう可能性があることご了承ください。
タカヒロ様 おはようございます。お忙しい中ご回答ありがとうございます。ファイル名が重複しているものが、番号を振られてフォルダに保存されること、稼働確認いたしました！ありがとうございました。
ただ、また問題が発生しており、重複していない名前の添付ファイルもメールの中にはありまして、それらがフォルダへ移動しない仕様になってしまいました。
拡張子がついているファイルを指定しているはずなのですが…。
重複しないファイルも一緒にフォルダへ移動させたいのですが、なにか方法はございますでしょうか。宜しくお願いいたします。
タカヒロ様 誠に迅速なご回答、非常に助かります。ほんとありがとうございます。
早速ですが、直下のフォルダ名は問題ないと思われます…。
実は、重複を回避するVBAを教えていただく前に、添付ファイルをフォルダに保存するというVBAを使用させていただき、うまく稼働いたしまして、その部分を貼り付けただけなんです。なので、フォルダ名や場所などは問題ないかと思われますが、恐ろしく初心者なので、なにかやらかしてるかもしれません。。。お忙しいと思いますので、お時間のある時にでもご教示お願いいたします。
フォルダ名は問題ないこと承知いたしました。
コードをみますと、オブジェクトobjFolderが後処理とつながっていないみたいですね。
あとItemsプロパティが抜けていたので追加していただければと存じます。
■変更前
Set objFolder = objInbox.Folders.Item(“★★★★サンクスカード集計”)
■変更後
Set objConItems = objInbox.Folders.Item(“★★★★サンクスカード集計”).Items
タカヒロ様 迅速なご回答誠にありがとうございます。早速ですが、重複しないvbaを使用させていただきました。が、受信トレイを指定する段階を変更したら、オブジェクトがないとエラーになりました。恐れ入りますが、ご教示いただけますでしょうか。
下記受信トレイを指定したつもりのコードです。
Sub 受信トレイの添付ファイルを一括保存_期間絞り込み_上書き回避()
Dim olApp As Application
Dim objInbox As Object
Dim objFolder As Object
Dim objItem As Object
Dim objConItems
Dim strPath As String
Dim i As Long
Dim j As Long
Dim strStart As String
Dim strEnd As String
Dim strFileName As String
Set objInbox = GetNamespace(“MAPI”).GetDefaultFolder(olFolderInbox)
‘添付ファイルがあるメールのフォルダを指定します。2階層以上ある場合は「.Folders.Item(＜フォルダ名＞)」を追加してください。
Set objFolder = objInbox.Folders.Item(“★★★★サンクスカード集計”)
‘添付ファイルの保存先をパスで指定します。
strPath = “C:\Users\”
‘開始日と終了日を指定します。
strStart = Format(“2022/7/1 00:00”, “yyyy/mm/dd hh:nn”) ‘開始日を指定
strEnd = Format(“2022/7/14 15:00”, “yyyy/mm/dd hh:nn”) ‘終了日を指定
‘Restrictメソッドで期間指定して抽出するメールアイテムを絞り込みます。
Set objConItems = objConItems.Restrict(“[ReceivedTime] >= ‘” & strStart & “‘ And [ReceivedTime] <= '" & strEnd & "'")
'アイテム数分処理を繰り返します。
For Each objItem In objConItems
For i = 1 To objItem.Attachments.Count
'添付ファイル名を変数へ代入します。
strFileName = objItem.Attachments.Item(i)
'添付ファイルに拡張子がある場合のみ処理します。
If InStr(strFileName, ".") 0 Then
‘フルパスが存在しない場合のみファイルを書き出します。
If Dir(strPath & strFileName) = “” Then
objItem.Attachments.Item(i).SaveAsFile strPath & strFileName
Else
j = 1
‘重複していたら保存ファイル名の先頭に(**)をつけます。
Do While Dir(strPath & strFileName) “”
strFileName = “(” & j & “)” & strFileName
j = j + 1
Loop
objItem.Attachments.Item(i).SaveAsFile strPath & strFileName
End If
End If
Next i
Next objItem
‘オブジェクトを解放します。
Set olApp = Nothing
Set objFolder = Nothing
Set objConItems = Nothing
Set objItem = Nothing
MsgBox “Outlook受信トレイの添付ファイル出力が完了しました！”, vbInformation
End Sub
ご連絡ありがとうございます。
オブジェクトがないエラーの件ですが、
下記フォルダが規定のユーザの受信トレイ直下（規定のユーザ＞受信トレイ＞★★★★サンクスカード集計）にあるか、
またフォルダ名は完全に一致しているかご確認頂けますでしょうか。
Set objFolder = objInbox.Folders.Item(“★★★★サンクスカード集計”)
続いてなのですが、期間を指定せず、任意の数字６桁が入っている件名を指定し、そのメールに添付されているExcelファイルを名前を付けて保存したい場合についても教えていただきたいです。数字６桁はメッセージBoxで入力するところまでは出来たのですが、その後ファイル名をその数字６桁でファイル保存をするところがうまくいかず…です。
ユニークな数字６桁の番号で件名を指定し、ファイル名もユニークになる為、
期間指定と繰り返し（loop）も不要になると思いますが、この認識が合っているかどうかが分からず、初心者の為大変ご面倒かけます。よろしくお願いいたします。
ご連絡ありがとうございます。
数字６桁の件名を指定し、添付ファイルを名前を付けて保存する件ですが、
前回追加の内容をベースに、
https://extan.jp/?p=8452#%EF%BC%9C%E8%BF%BD%E5%8A%A0%EF%BC%9EOutlook%E5%8F%97%E4%BF%A1%E3%83%88%E3%83%AC%E3%82%A4%E3%81%AE%E6%8C%87%E5%AE%9A%E4%BB%B6%E5%90%8D%E3%81%AE%E6%B7%BB%E4%BB%98%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E3%83%AA%E3%83%8D%E3%83%BC%E3%83%A0%E3%81%97%E3%81%A6%E4%B8%80%E6%8B%AC%E4%BF%9D%E5%AD%98%E3%81%99%E3%82%8BVBA
数字6桁用の変数を追加、値を代入し、
Dim ＜数字6桁の変数＞ As Long
＜数字6桁の変数＞ = “000000”
以下の箇所を変更すれば実現すると思われます。
strTokuteiSubject = ＜数字6桁の変数＞
strFileName = ＜数字6桁の変数＞ & objItem.Attachments.Item(i)
よろしくお願いいたします。
outlookで添付ファイルを保存できました！
もし可能でしたら、フォルダ内へ移動せずに受信トレイで指定したメールのみの添付ファイルに名前を付けて指定フォルダ内へ保存する。というVBAを教えていただけますでしょうか。
いつもご利用ありがとうございます。
また実行できたようでよかったです。
ご質問の指定した件名の添付ファイルに対し、名前を付けた上指定フォルダ内へ保存する件につきまして、
記事に追加しましたのでよろしければご参照ください。
https://extan.jp/?p=8452#%EF%BC%9C%E8%BF%BD%E5%8A%A0%EF%BC%9EOutlook%E5%8F%97%E4%BF%A1%E3%83%88%E3%83%AC%E3%82%A4%E3%81%AE%E6%8C%87%E5%AE%9A%E4%BB%B6%E5%90%8D%E3%81%AE%E6%B7%BB%E4%BB%98%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E3%83%AA%E3%83%8D%E3%83%BC%E3%83%A0%E3%81%97%E3%81%A6%E4%B8%80%E6%8B%AC%E4%BF%9D%E5%AD%98%E3%81%99%E3%82%8BVBA