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
参考
