受信したメールと添付ファイルを指定したフォルダに保存するOutlook VBAのスクリプト。

諸般の事情で作ったので以下に晒しておく。
保存先のフォルダをDropbox管理下のフォルダにすると、外からメール確認ができたりする。

' 受信したメールが、指定した条件に一致するとき、
' そのメールと添付ファイルを ROOT_PATH 内に保存する。
'
' メールは以下の要領で保存される。
' - ROOT_PATHフォルダ内の、現在日(yyyymmdd形式)の名前のフォルダ内に保存される。
' - メールは、現在日のフォルダ内に以下の名前で保存される。
'      [hhmmdd形式の受信時間]_[件名].txt
' - 添付ファイルは、現在日のフォルダ内の以下のフォルダ内に保存される。
'      [hhmmdd形式の受信時間]_[件名]
    
' メールの保存先のフォルダ
Const ROOT_PATH = "c:\tekito"


' 条件は以下で設定する。
' 各項目は、独立しており、いずれかの条件が一致すると
' メールが保存される。
'    - INCLUDE_TO   : 宛先
'    - INCLUDE_CC   : CC
'    - INCLUDE_FROM : 差出人
'    - INCLUDE_SUBJ : 件名
' 各項目は、カンマ区切りで複数の文字列を指定でき、
' いずれかの文字列が対象の文字列に含まれている場合に
' メールを保存する。
'TO(宛先)に含まれる文字列をカンマ区切りで指定する。
Const INCLUDE_TO = "tekito,適当"
'CCに含まれる文字列をカンマ区切りで指定する。
Const INCLUDE_CC = "tekito,適当"
'FROM(差出人)に含まれる文字列をカンマ区切りで指定する。
Const INCLUDE_FROM = "tekito,適当"
'件名に含まれる文字列をカンマ区切りで指定する。
Const INCLUDE_SUBJ = "tekito,適当"

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    
    Dim savePath As String
    Dim objFSO As Object ' FileSystemObject
    Dim colID As Variant
    Dim i As Integer
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    savePath = ROOT_PATH & "\" & Format(Date, "yyyymmdd")
    If Not objFSO.FolderExists(savePath) Then
        objFSO.CreateFolder savePath
    End If
    
    Set objFSO = Nothing
    
    If InStr(EntryIDCollection, ",") = 0 Then
        SaveMsgFile savePath, EntryIDCollection
    Else
        colID = Split(EntryIDCollection, ",")
        For i = LBound(colID) To UBound(colID)
            SaveMsgFile savePath, colID(i)
        Next
    End If
End Sub


Private Sub SaveMsgFile(ByVal savePath, ByVal strEntryID As String)
    
    Dim mi As MailItem
    Dim fileName As String
    Dim expTo As String
    Dim expCC As String
    Dim epxFrom As String
    
    Set mi = Application.Session.GetItemFromID(strEntryID)
    
    expTo = StrRecipient(mi.Recipients, olTo)
    expCC = StrRecipient(mi.Recipients, olCC)
    expFrom = mi.SenderEmailAddress & "/" & mi.SenderName
    
    If InStrOr(expTo, INCLUDE_TO) Or _
       InStrOr(expCC, INCLUDE_CC) Or _
       InStrOr(mi.Subject, INCLUDE_SUBJ) Or _
       InStrOr(expFrom, INCLUDE_FROM) Then
        
        fileName = EscapeFileName(Left(Format(mi.ReceivedTime, "hhnnss") & "_" & mi.Subject, 100))
        
        mi.SaveAs savePath & "\" & fileName & ".txt", olTXT
        
        SaveAttachments savePath & "\" & fileName, mi.Attachments
    
    End If
    
    Set mi = Nothing
End Sub

Private Function EscapeFileName(ByVal fileName As String) As String
    fileName = Replace(fileName, "/", "／")
    fileName = Replace(fileName, "\", "￥")
    fileName = Replace(fileName, "<", "＜")
    fileName = Replace(fileName, ">", "＞")
    fileName = Replace(fileName, "*", "＊")
    fileName = Replace(fileName, "?", "？")
    fileName = Replace(fileName, """", "'")
    fileName = Replace(fileName, "|", "｜")
    fileName = Replace(fileName, ":", "：")
    fileName = Replace(fileName, ";", "；")
    EscapeFileName = fileName
End Function

Private Sub SaveAttachments(ByVal savePath As String, ByVal atchs As Attachments)
    Dim objFSO As Object
    Dim objFile As Object
    
    If atchs.Count > 0 Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        
        If Not objFSO.FolderExists(savePath) Then
            objFSO.CreateFolder savePath
        End If
        
        For Each objFile In atchs
            objFile.SaveAsFile savePath & "\" & objFile.DisplayName
        Next objFile
    End If
    
    Set objFSO = Nothing
    Set objFile = Nothing
End Sub

Private Function InStrOr(ByVal exp As String, ByVal strConds As String) As Boolean
    Dim conds As Variant
    Dim i As Integer
    Dim cond As String
    
    conds = Split(strConds, ",")
    For i = LBound(conds) To UBound(conds)
        cond = conds(i)
        If InStr(exp, cond) > 0 Then
            InStrOr = True
            Exit Function
        End If
    Next
    InStrOr = False
    Exit Function
End Function

Private Function InStrAnd(ByVal exp As String, ByVal strConds As String) As Boolean
    Dim conds As Variant
    Dim i As Integer
    Dim cond As String
    
    conds = Split(strConds, ",")
    For i = LBound(conds) To UBound(conds)
        cond = conds(i)
        If Not InStr(exp, cond) > 0 Then
            InStrAnd = False
            Exit Function
        End If
    Next
    InStrAnd = True
    Exit Function
End Function

Private Function StrRecipient(ByVal recs As Recipients, ByVal recType As Long) As String
    Dim rec As recipient
    Dim i As Integer
    Dim ret As String
    
    ret = ""
    
    For Each rec In recs
        If rec.Type = recType Then
            ret = ret & rec.Address & "/" & rec.Name & " "
        End If
    Next rec
    
    StrRecipient = ret
    Exit Function
End Function