Sub SaveOutlookMessagesWithDifferentFilenames()
Dim olApp As Object
Dim olNamespace As Object
Dim olFolder As Object
Dim olItem As Object
Dim strOutputFolder As String
Dim fs As Object
Dim outFile As Object
Dim isSentByMe As Boolean
' Outlook アプリケーションを取得
Set olApp = CreateObject("Outlook.Application")
' Outlook 名前空間を取得
Set olNamespace = olApp.GetNamespace("MAPI")
' 対象のメールフォルダを指定（例: 受信トレイ）
Set olFolder = olNamespace.GetDefaultFolder(6) ' 6 は受信トレイの定数
' 出力先フォルダを指定
strOutputFolder = "C:\Your\Output\Folder\Path\"
' 出力先フォルダが存在しない場合は作成
If Dir(strOutputFolder, vbDirectory) = "" Then
MkDir strOutputFolder
End If
' メールフォルダ内の各メッセージを処理
For Each olItem In olFolder.Items
' 本人が送信したメールかどうかを判定
isSentByMe = (olItem.SentOnBehalfOfName = olNamespace.CurrentUser.Name)
' ファイル名を生成
Dim fileName As String
If isSentByMe Then
fileName = strOutputFolder & Format(olItem.SentOn, "yyyymmdd") & "_" & Replace(Replace(olItem.Subject, ":", "_"), "/", "_") & "_" & Replace(olItem.ReceivedByName, " ", "_") & ".txt"
Else
fileName = strOutputFolder & Format(olItem.ReceivedTime, "yyyymmdd") & "_" & Replace(Replace(olItem.Subject, ":", "_"), "/", "_") & "_" & Replace(olItem.SenderEmailAddress, "@", "_") & ".txt"
End If
' テキストファイルにメッセージを保存
Set fs = CreateObject("Scripting.FileSystemObject")
Set outFile = fs.CreateTextFile(fileName, True)
outFile.WriteLine "Subject: " & olItem.Subject
outFile.WriteLine "Sender: " & olItem.SenderEmailAddress
If isSentByMe Then
outFile.WriteLine "To: " & olItem.ReceivedByName
outFile.WriteLine "Sent Time: " & olItem.SentOn
Else
outFile.WriteLine "Received Time: " & olItem.ReceivedTime
End If
outFile.WriteLine "Body: " & olItem.Body
outFile.Close
Next olItem
' 解放
Set olApp = Nothing
Set olNamespace = Nothing
Set olFolder = Nothing
Set olItem = Nothing
Set fs = Nothing
Set outFile = Nothing
End Sub
