Public Sub 受信トレイ個別テキスト化() Dim myNamespace As Outlook.NameSpace Dim myFolder As Outlook.MAPIFolder Dim ToItem As Outlook.MailItem Dim RC As Long Dim I As Long Dim PosErrStr As Long Dim ToSubject As String Dim FName As String Dim FNameErrStr() As Variant Dim FNameChgStr() As Variant '*** 下にテキストファイルを出力するフォルダを記述して下さい。最後は必ず()で。 Const SaveFolder As String = "C:XXXXXXXX"
FNameErrStr = Array(":", "", "/", "|", "<", ">", Chr(&H22)) '**ファイル名に使えない文字 FNameChgStr = Array(";", "$", "-", "!", "(", ")", "'") '**上の文字のかわりに使う文字 Set myNamespace = Application.GetNamespace("MAPI") Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox) For Each ToItem In myFolder.Items ToSubject = Trim(CStr(ToItem.Subject)) For I = 0& To UBound(FNameErrStr) PosErrStr = InStr(ToSubject, FNameErrStr(I)) Do Until PosErrStr = 0& Mid(ToSubject, PosErrStr, 1&) = FNameChgStr(I) PosErrStr = InStr(ToSubject, FNameErrStr(I)) Loop Next FName = SaveFolder + _ Format(ToItem.ReceivedTime, "yyyymmdd_hhnnss") + _ "_" + ToSubject + ".txt" ToItem.SaveAs FName, olTXT Next Set ToItem = Nothing Set myFolder = Nothing Set myNamespace = Nothing MsgBox "END" End End Sub