🧑🏫 ケンタと先生のVBA教室：固定フォルダに自動保存編
〜お宝メールを狙い撃ち！秘密のフォルダへ爆速お引越し大作戦〜
先生：「よしケンタ、コードを送ってくれてありがとうな！今回は、君がOutlookで『あの人のメール、テキストで残したいねん！』って言ったのを、パソコンくんが裏で一瞬で片付ける魔法の指示書や！」
👦ケンタ：「先生、これ英語ばっかりで呪文みたいやけど、上から順番に何が起きてるの？まず最初の
savePath = "C:\メール履歴\" ってところは？」🤠先生：「そこはな、パソコンくんに**『お宝（メール）をしまう秘密の基地はここやで！』**って住所を教えてるんや。しかもその下が優秀でな、もしパソコンの中にそのフォルダがなかったら、パソコンくんが『お、基地がないやんけ！作ったろ！』って、スコップ持って自動でフォルダを掘り起こしてくれるんやで！」
👦ケンタ：「へぇー、勝手に部屋を作ってくれるんや！で、その次の
InputBox ってやつで、画面にポップアップが出るわけやな？」🤠先生：「大正解！画面に『誰のメール探す？』って手紙が出てくるから、そこに相手の名前とかアドレスを打ち込む。もし何も入れずにキャンセルしたら、パソコンくんは『なんや、やらへんのかい！』ってズッコケて、安全に仕事をサボる（終了する）ようになってんねん」
👦ケンタ：「あはは、サボるんや（数行飛ばして）。あ、真ん中あたりに
For Each item In folder.Items ってある！出たな、ループ！」🤠先生：「おう、大ボスの登場や！ここからパソコンくんがダッシュで受信トレイに走り込んで、メールを1通ずつ上からめくっていくんや。**『これ、ケンタが言うてた人のメールか？違う！次！これか？あ、これや！』**ってな」
👦ケンタ：「あ！その見つけたあとのところで、
Replace ってのがいっぱい並んでるけど、これ何？めちゃくちゃしつこいねんけど！」🤠先生：「ガハハ！これはな、メールのタイトルに『/』とか『:』みたいな、パソコンのファイル名に使ったらアカン禁止文字が入ってたときに、パソコンくんが『これジャマやから消しといたろ！』って消しゴムで消しまくってる処理や。これがないとエラーで爆発（フリーズ）してまうから、超大事な優しさチェックなんやで」
👦ケンタ：「なるほど、爆発防止の消しゴムか！じゃあ、その下の
mail.Attachments.Count > 0 ってのは？」🤠先生：「そこがケンタのリクエスト通りや！メールに書類（添付ファイル）がくっついてるかジロジロ見て、**『おっ、書類つきやんけ！頭に●マークをプレゼントしたろ！』**って、ファイル名に●をペタッと貼る判定をしてるんやな」
👦ケンタ：「ほんまや、ちゃんと●がつく！で、最後に
Print #fileNum ってところで、ノート（テキストファイル）に書き写してるん？」🤠先生：「せや！指定された秘密のフォルダの中に、新しくテキストファイルを作って、**『【日付】はいついつ、【タイトル】はこれ、中身の【メール内容】はこれ！』**って、サラサラサラーッと猛スピードで書き写して、最後にファイルをパタンと閉じる（
Close）んや！」👦ケンタ：「すごっ！それを、頼んだ人のメールが見つかるたびに、何回でも繰り返すんやな！」
🤠先生：「その通り！全部のメールをチェックし終わったら、最後に**『◯件のメールを保存したで！ドヤァ！』**って画面に完了の報告（
MsgBox）を出して、ハッピーエンドや！」👦ケンタ：「ワォ！英語の呪文やと思ってたけど、パソコンくんが優しく部屋を作って、消しゴムで文字を消して、●をつけて書き写してくれてる様子がめっちゃ目に浮かんだわ！」
Sub ExportEmailToFixedFolder()
Dim outlookApp As Outlook.Application
Dim ns As Outlook.NameSpace
Dim folder As Outlook.MAPIFolder
Dim item As Object
Dim mail As Outlook.MailItem
Dim targetSender As String
Dim savePath As String
Dim filePath As String
Dim cleanedSubject As String
Dim fileName As String
Dim attachMarker As String
Dim fileNum As Integer
Dim matchCount As Integer
Dim fso As Object
' ==== 【重要】ここに保存したいフォルダのパスを入力してください ====
' ※末尾には必ず「\」を付けてください
savePath = "C:\メール履歴\"
' ==================================================================
' フォルダが存在するか確認し、なければ自動作成する
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(savePath) Then
On Error Resume Next
fso.CreateFolder(savePath)
On Error GoTo 0
' 作成に失敗した場合の安全対策
If Not fso.FolderExists(savePath) Then
MsgBox "指定されたフォルダ 「" & savePath & "」 が存在せず、作成もできませんでした。パスを確認してください。", vbCritical
Exit Sub
End If
End If
' ポップアップで抽出したい相手を入力させる
targetSender = InputBox("抽出したい相手の「メールアドレス」または「名前」を入力してください。", "差出人の指定")
' キャンセルボタンが押されたか、何も入力されなかった場合は終了
If Trim(targetSender) = "" Then
MsgBox "処理をキャンセルしました。", vbExclamation
Exit Sub
End If
Set outlookApp = New Outlook.Application
Set ns = outlookApp.GetNamespace("MAPI")
' 現在開いているフォルダーを対象にする
Set folder = outlookApp.ActiveExplorer.CurrentFolder
matchCount = 0
' フォルダー内のアイテムをループ処理
For Each item In folder.Items
If TypeOf item Is MailItem Then
Set mail = item
' 差出人の判定
If InStr(mail.SenderEmailAddress, targetSender) > 0 Or InStr(mail.SenderName, targetSender) > 0 Then
matchCount = matchCount + 1
' 件名からファイル名に使えない禁止文字（\ / : * ? " < > |）を削除
cleanedSubject = mail.Subject
cleanedSubject = Replace(cleanedSubject, "\", ""): cleanedSubject = Replace(cleanedSubject, "/", "")
cleanedSubject = Replace(cleanedSubject, ":", ""): cleanedSubject = Replace(cleanedSubject, "*", "")
cleanedSubject = Replace(cleanedSubject, "?", ""): cleanedSubject = Replace(cleanedSubject, """", "")
cleanedSubject = Replace(cleanedSubject, "<", ""): cleanedSubject = Replace(cleanedSubject, ">", "")
cleanedSubject = Replace(cleanedSubject, "|", "")
' 添付ファイルの有無をチェック（あれば ●、なければ 空白）
If mail.Attachments.Count > 0 Then
attachMarker = "●"
Else
attachMarker = ""
End If
' ファイル名を作成（差出人名_●件名_年月.txt）
fileName = mail.SenderName & "_" & attachMarker & cleanedSubject & "_" & Format(mail.ReceivedTime, "yyyymm") & ".txt"
filePath = savePath & fileName
' 個別のテキストファイルを開いて書き込み
fileNum = FreeFile
Open filePath For Output As #fileNum
Print #fileNum, "【日付】 " & mail.ReceivedTime
Print #fileNum, "【タイトル】 " & mail.Subject
Print #fileNum, "【メール内容】"
Print #fileNum, mail.Body
Close #fileNum
End If
End If
Next item
' 結果の通知
If matchCount > 0 Then
MsgBox matchCount & " 件のメールを 「" & savePath & "」 に保存しました！", vbInformation
Else
MsgBox "該当するメールが見つかりませんでした。", vbExclamation
End If
End Sub
Dim outlookApp As Outlook.Application
Dim ns As Outlook.NameSpace
Dim folder As Outlook.MAPIFolder
Dim item As Object
Dim mail As Outlook.MailItem
Dim targetSender As String
Dim savePath As String
Dim filePath As String
Dim cleanedSubject As String
Dim fileName As String
Dim attachMarker As String
Dim fileNum As Integer
Dim matchCount As Integer
Dim fso As Object
' ==== 【重要】ここに保存したいフォルダのパスを入力してください ====
' ※末尾には必ず「\」を付けてください
savePath = "C:\メール履歴\"
' ==================================================================
' フォルダが存在するか確認し、なければ自動作成する
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(savePath) Then
On Error Resume Next
fso.CreateFolder(savePath)
On Error GoTo 0
' 作成に失敗した場合の安全対策
If Not fso.FolderExists(savePath) Then
MsgBox "指定されたフォルダ 「" & savePath & "」 が存在せず、作成もできませんでした。パスを確認してください。", vbCritical
Exit Sub
End If
End If
' ポップアップで抽出したい相手を入力させる
targetSender = InputBox("抽出したい相手の「メールアドレス」または「名前」を入力してください。", "差出人の指定")
' キャンセルボタンが押されたか、何も入力されなかった場合は終了
If Trim(targetSender) = "" Then
MsgBox "処理をキャンセルしました。", vbExclamation
Exit Sub
End If
Set outlookApp = New Outlook.Application
Set ns = outlookApp.GetNamespace("MAPI")
' 現在開いているフォルダーを対象にする
Set folder = outlookApp.ActiveExplorer.CurrentFolder
matchCount = 0
' フォルダー内のアイテムをループ処理
For Each item In folder.Items
If TypeOf item Is MailItem Then
Set mail = item
' 差出人の判定
If InStr(mail.SenderEmailAddress, targetSender) > 0 Or InStr(mail.SenderName, targetSender) > 0 Then
matchCount = matchCount + 1
' 件名からファイル名に使えない禁止文字（\ / : * ? " < > |）を削除
cleanedSubject = mail.Subject
cleanedSubject = Replace(cleanedSubject, "\", ""): cleanedSubject = Replace(cleanedSubject, "/", "")
cleanedSubject = Replace(cleanedSubject, ":", ""): cleanedSubject = Replace(cleanedSubject, "*", "")
cleanedSubject = Replace(cleanedSubject, "?", ""): cleanedSubject = Replace(cleanedSubject, """", "")
cleanedSubject = Replace(cleanedSubject, "<", ""): cleanedSubject = Replace(cleanedSubject, ">", "")
cleanedSubject = Replace(cleanedSubject, "|", "")
' 添付ファイルの有無をチェック（あれば ●、なければ 空白）
If mail.Attachments.Count > 0 Then
attachMarker = "●"
Else
attachMarker = ""
End If
' ファイル名を作成（差出人名_●件名_年月.txt）
fileName = mail.SenderName & "_" & attachMarker & cleanedSubject & "_" & Format(mail.ReceivedTime, "yyyymm") & ".txt"
filePath = savePath & fileName
' 個別のテキストファイルを開いて書き込み
fileNum = FreeFile
Open filePath For Output As #fileNum
Print #fileNum, "【日付】 " & mail.ReceivedTime
Print #fileNum, "【タイトル】 " & mail.Subject
Print #fileNum, "【メール内容】"
Print #fileNum, mail.Body
Close #fileNum
End If
End If
Next item
' 結果の通知
If matchCount > 0 Then
MsgBox matchCount & " 件のメールを 「" & savePath & "」 に保存しました！", vbInformation
Else
MsgBox "該当するメールが見つかりませんでした。", vbExclamation
End If
End Sub
年月日指定版
Sub ExportEmailToFixedFolder2()
Dim outlookApp As Outlook.Application
Dim ns As Outlook.NameSpace
Dim folder As Outlook.MAPIFolder
Dim item As Object
Dim mail As Outlook.MailItem
Dim targetSender As String
Dim startDateInput As String, endDateInput As String
Dim startDate As Date, endDate As Date
Dim savePath As String
Dim filePath As String
Dim cleanedSubject As String
Dim fileName As String
Dim attachMarker As String
Dim fileNum As Integer
Dim matchCount As Integer
Dim fso As Object
' ==== 【重要】ここに保存したいフォルダのパスを入力してください ====
' ※末尾には必ず「\」を付けてください
savePath = "C:\メール履歴\"
' ==================================================================
' フォルダが存在するか確認し、なければ自動作成する
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(savePath) Then
On Error Resume Next
fso.CreateFolder(savePath)
On Error GoTo 0
' 作成に失敗した場合の安全対策
If Not fso.FolderExists(savePath) Then
MsgBox "指定されたフォルダ 「" & savePath & "」 が存在せず、作成もできませんでした。パスを確認してください。", vbCritical
Exit Sub
End If
End If
' ポップアップで抽出したい相手を入力させる
targetSender = InputBox("抽出したい相手の「メールアドレス」または「名前」を入力してください。", "差出人の指定")
If Trim(targetSender) = "" Then
MsgBox "処理をキャンセルしました。", vbExclamation
Exit Sub
End If
' 【変更】開始日の入力（初期値は今日の日付）
startDateInput = InputBox("抽出する【開始日】を入力してください。" & vbCrLf & "(例: 2026/01/01)", "開始日の指定", Format(Date, "yyyy/mm/dd"))
If Trim(startDateInput) = "" Then MsgBox "処理をキャンセルしました。", vbExclamation: Exit Sub
If Not IsDate(startDateInput) Then
MsgBox "正しい日付を入力してください。処理を終了します。", vbCritical
Exit Sub
End If
' 開始日の「00:00:00」として設定
startDate = CDate(startDateInput)
' 【変更】終了日の入力（初期値は今日の日付）
endDateInput = InputBox("抽出する【終了日】を入力してください。" & vbCrLf & "(例: 2026/01/31)", "終了日の指定", Format(Date, "yyyy/mm/dd"))
If Trim(endDateInput) = "" Then MsgBox "処理をキャンセルしました。", vbExclamation: Exit Sub
If Not IsDate(endDateInput) Then
MsgBox "正しい日付を入力してください。処理を終了します。", vbCritical
Exit Sub
End If
' 終了日の「23:59:59」まで含めるために、翌日の00:00:00未満という条件で判定します
endDate = DateAdd("d", 1, CDate(endDateInput))
Set outlookApp = New Outlook.Application
Set ns = outlookApp.GetNamespace("MAPI")
' 現在開いているフォルダーを対象にする
Set folder = outlookApp.ActiveExplorer.CurrentFolder
matchCount = 0
' フォルダー内のアイテムをループ処理
For Each item In folder.Items
If TypeOf item Is MailItem Then
Set mail = item
' 差出人の判定 ＋ 受信日時の判定（開始日0:00以上、かつ終了日の翌日0:00未満）
If (InStr(mail.SenderEmailAddress, targetSender) > 0 Or InStr(mail.SenderName, targetSender) > 0) And _
(mail.ReceivedTime >= startDate And mail.ReceivedTime < endDate) Then
matchCount = matchCount + 1
' 件名からファイル名に使えない禁止文字（\ / : * ? " < > |）を削除
cleanedSubject = mail.Subject
cleanedSubject = Replace(cleanedSubject, "\", ""): cleanedSubject = Replace(cleanedSubject, "/", "")
cleanedSubject = Replace(cleanedSubject, ":", ""): cleanedSubject = Replace(cleanedSubject, "*", "")
cleanedSubject = Replace(cleanedSubject, "?", ""): cleanedSubject = Replace(cleanedSubject, """", "")
cleanedSubject = Replace(cleanedSubject, "<", ""): cleanedSubject = Replace(cleanedSubject, ">", "")
cleanedSubject = Replace(cleanedSubject, "|", "")
' 添付ファイルの有無をチェック（あれば ●、なければ 空白）
If mail.Attachments.Count > 0 Then
attachMarker = "●"
Else
attachMarker = ""
End If
' ファイル名を作成（差出人名_●件名_年月.txt）
fileName = mail.SenderName & "_" & attachMarker & cleanedSubject & "_" & Format(mail.ReceivedTime, "yyyymm") & ".txt"
filePath = savePath & fileName
' 個別のテキストファイルを開いて書き込み
fileNum = FreeFile
Open filePath For Output As #fileNum
Print #fileNum, "【日付】 " & mail.ReceivedTime
Print #fileNum, "【タイトル】 " & mail.Subject
Print #fileNum, "【メール内容】"
Print #fileNum, mail.Body
Close #fileNum
End If
End If
Next item
' 結果の通知
If matchCount > 0 Then
MsgBox matchCount & " 件のメールを 「" & savePath & "」 に保存しました！", vbInformation
Else
MsgBox "該当するメールが見つかりませんでした。", vbExclamation
End If
End Sub
Dim outlookApp As Outlook.Application
Dim ns As Outlook.NameSpace
Dim folder As Outlook.MAPIFolder
Dim item As Object
Dim mail As Outlook.MailItem
Dim targetSender As String
Dim startDateInput As String, endDateInput As String
Dim startDate As Date, endDate As Date
Dim savePath As String
Dim filePath As String
Dim cleanedSubject As String
Dim fileName As String
Dim attachMarker As String
Dim fileNum As Integer
Dim matchCount As Integer
Dim fso As Object
' ==== 【重要】ここに保存したいフォルダのパスを入力してください ====
' ※末尾には必ず「\」を付けてください
savePath = "C:\メール履歴\"
' ==================================================================
' フォルダが存在するか確認し、なければ自動作成する
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(savePath) Then
On Error Resume Next
fso.CreateFolder(savePath)
On Error GoTo 0
' 作成に失敗した場合の安全対策
If Not fso.FolderExists(savePath) Then
MsgBox "指定されたフォルダ 「" & savePath & "」 が存在せず、作成もできませんでした。パスを確認してください。", vbCritical
Exit Sub
End If
End If
' ポップアップで抽出したい相手を入力させる
targetSender = InputBox("抽出したい相手の「メールアドレス」または「名前」を入力してください。", "差出人の指定")
If Trim(targetSender) = "" Then
MsgBox "処理をキャンセルしました。", vbExclamation
Exit Sub
End If
' 【変更】開始日の入力（初期値は今日の日付）
startDateInput = InputBox("抽出する【開始日】を入力してください。" & vbCrLf & "(例: 2026/01/01)", "開始日の指定", Format(Date, "yyyy/mm/dd"))
If Trim(startDateInput) = "" Then MsgBox "処理をキャンセルしました。", vbExclamation: Exit Sub
If Not IsDate(startDateInput) Then
MsgBox "正しい日付を入力してください。処理を終了します。", vbCritical
Exit Sub
End If
' 開始日の「00:00:00」として設定
startDate = CDate(startDateInput)
' 【変更】終了日の入力（初期値は今日の日付）
endDateInput = InputBox("抽出する【終了日】を入力してください。" & vbCrLf & "(例: 2026/01/31)", "終了日の指定", Format(Date, "yyyy/mm/dd"))
If Trim(endDateInput) = "" Then MsgBox "処理をキャンセルしました。", vbExclamation: Exit Sub
If Not IsDate(endDateInput) Then
MsgBox "正しい日付を入力してください。処理を終了します。", vbCritical
Exit Sub
End If
' 終了日の「23:59:59」まで含めるために、翌日の00:00:00未満という条件で判定します
endDate = DateAdd("d", 1, CDate(endDateInput))
Set outlookApp = New Outlook.Application
Set ns = outlookApp.GetNamespace("MAPI")
' 現在開いているフォルダーを対象にする
Set folder = outlookApp.ActiveExplorer.CurrentFolder
matchCount = 0
' フォルダー内のアイテムをループ処理
For Each item In folder.Items
If TypeOf item Is MailItem Then
Set mail = item
' 差出人の判定 ＋ 受信日時の判定（開始日0:00以上、かつ終了日の翌日0:00未満）
If (InStr(mail.SenderEmailAddress, targetSender) > 0 Or InStr(mail.SenderName, targetSender) > 0) And _
(mail.ReceivedTime >= startDate And mail.ReceivedTime < endDate) Then
matchCount = matchCount + 1
' 件名からファイル名に使えない禁止文字（\ / : * ? " < > |）を削除
cleanedSubject = mail.Subject
cleanedSubject = Replace(cleanedSubject, "\", ""): cleanedSubject = Replace(cleanedSubject, "/", "")
cleanedSubject = Replace(cleanedSubject, ":", ""): cleanedSubject = Replace(cleanedSubject, "*", "")
cleanedSubject = Replace(cleanedSubject, "?", ""): cleanedSubject = Replace(cleanedSubject, """", "")
cleanedSubject = Replace(cleanedSubject, "<", ""): cleanedSubject = Replace(cleanedSubject, ">", "")
cleanedSubject = Replace(cleanedSubject, "|", "")
' 添付ファイルの有無をチェック（あれば ●、なければ 空白）
If mail.Attachments.Count > 0 Then
attachMarker = "●"
Else
attachMarker = ""
End If
' ファイル名を作成（差出人名_●件名_年月.txt）
fileName = mail.SenderName & "_" & attachMarker & cleanedSubject & "_" & Format(mail.ReceivedTime, "yyyymm") & ".txt"
filePath = savePath & fileName
' 個別のテキストファイルを開いて書き込み
fileNum = FreeFile
Open filePath For Output As #fileNum
Print #fileNum, "【日付】 " & mail.ReceivedTime
Print #fileNum, "【タイトル】 " & mail.Subject
Print #fileNum, "【メール内容】"
Print #fileNum, mail.Body
Close #fileNum
End If
End If
Next item
' 結果の通知
If matchCount > 0 Then
MsgBox matchCount & " 件のメールを 「" & savePath & "」 に保存しました！", vbInformation
Else
MsgBox "該当するメールが見つかりませんでした。", vbExclamation
End If
End Sub
