2017.06.29 :この記事の続きを こちらで書きました
save_mail.vba
Function p(s)
Debug.Print (s)
End Function
Public Sub save_aaaa_mail()
Call save_mail("aaaa", "C:\test", "aaaa\gmail")
' C:\test\aaaa\gmail\yyyymmdd_hhnnss(受信日時)
End Sub
'
' save_mail(ByVal target As String, ByVal base_folder As String, ByVal sub_folder As String)
' 引数
' - target : メールアドレスに含まれる文字列
' - base_folder : 保存する場所のパス
' - sub_folder : サブフォルダ
' 使い方
' Call save_mail("aaaa", "C:\test", "aaaa\gmail")
' → C:\test\aaaa\gmail\yyyymmdd_hhnnss(受信日時)の形でメールが保存されていく。
' 備考
' "mail.SaveAs file_name, olTXT"の部分でテキストで保存を決め打ちにしているので適宜変更
Public Function save_mail(ByVal target As String, ByVal base_folder As String, ByVal sub_folder As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim mail_from As String
mail_from = "_from"
Dim mail_to As String
mail_to = "_to"
' ビュー一覧のうち選択したメールに対して保存処理をする
Dim mail As Object
For Each mail In ActiveExplorer.Selection
' 保存したいメールアドレスが含まれているかチェックする
' 送信者アドレス(SenderEmailAddress) → なかったら → 受信者アドレス(RecipientのAddress)
' mdirが空文字列("")だったら、TERGETではないのでスキップする
Dim mdir As String
Dim sndr_addr As String
mdir = ""
sndr_addr = mail.SenderEmailAddress
If InStr(1, sndr_addr, target, vbTextCompare) > 0 Then
mdir = mail_from
Else
Dim r As Recipient
For Each r In mail.Recipients
If InStr(1, r.ADDRESS, target, vbTextCompare) > 0 Then
mdir = mail_to
Exit For
End If
Next
End If
' 保存したいメールアドレスが無かったので次のメールへ(Continue)
' VBAでループをスキップする方法 ; http://netbusinesstips.seesaa.net/article/432196855.html
If mdir = "" Then
GoTo Continue ' Continue文がないので、GoToで代用。
End If
' フォルダ名(受信日時)<mdir>
Dim folder_name As String
folder_name = fso.buildPath(base_folder, sub_folder)
folder_name = fso.buildPath(folder_name, Format(mail.ReceivedTime, "yyyymmdd_hhnnss") & mdir)
'p (folder_name)
' 同名フォルダチェック。すでにあったら何もしない。再帰的に作る
createFolderRecursive fso, folder_name
' ファイル名(メール件名)
Dim file_name As String
file_name = replaceNGchar(mail.Subject, "_") & ".txt"
file_name = replaceWhiteSpace(file_name, "_")
file_name = fso.buildPath(folder_name, file_name)
'Debug.Print file_name
' メールをテキストとして保存。すでにあったら何もしない。なければ保存。。
If fso.FileExists(file_name) Then
' すでにあった
Else
mail.SaveAs file_name, olTXT
End If
' 添付ファイル
Dim f As Attachment
Dim attach_fname As String
For Each f In mail.Attachments
' 添付ファイル名
attach_fname = fso.buildPath(folder_name, replaceNGchar(f.DisplayName, "_"))
'添付ファイルを保存する。すでにあったら何もしない。なければ保存。
If fso.FileExists(attach_fname) Then
' すでにあった
Else
f.SaveAsFile attach_fname
End If
Next
Set mail = Nothing
Continue:
' Continue文がないので、GoToで代用
Next
save_mail = True
End Function
Sub createFolderRecursive(ByRef fso As Object, ByVal folder As String)
Dim parent As String
parent = fso.GetParentFolderName(folder)
If parent <> "" Then
If Not fso.FolderExists(parent) Then
createFolderRecursive fso, parent
End If
End If
If Not fso.FolderExists(folder) Then
fso.CreateFolder folder
End If
End Sub
Public Function replaceNGchar(ByVal str As String, _
Optional ByVal replaceChar As String = "") As String
Const NG_CHARS = "\/:*?""""<>|[]"
str = replaceChars(str, NG_CHARS, replaceChar)
replaceNGchar = str
End Function
Public Function replaceWhiteSpace(ByVal str As String, _
Optional ByVal replaceChar As String = "") As String
Const WHITE_SPACE = " "
str = replaceChars(str, WHITE_SPACE, replaceChar)
replaceWhiteSpace = str
End Function
Public Function replaceChars( _
ByVal str As String, _
ByVal check_chars As String, _
ByVal replaceChar As String) As String
For i = 0 To Len(check_chars) - 1
str = Replace(str, Mid(check_chars, i + 1, 1), replaceChar)
Next i
replaceChars = str
End Function