outlookで使えるメールの振り分けマクロ

#1.outlookのメール振り分けめんどくさい
個人的にちょいとめんどい

#2.とりあえずマクロ化（標準モジュールとして）

furiwake.bas

Sub mailFuriwake()
    
    Dim oNamespace As NameSpace
    
    Dim oFolder As Outlook.Folder 'フォルダー
    Dim mITEM As Outlook.MailItem 'メールアイテム
    Dim n As Integer              'ループのカウンター
    Dim subFolder As Folder       'サブフォルダー１つ下を探る
    Dim c As Integer              'フォルダのループカウンタ
    'フォルダの日時
    Dim folderDateTime As String
    'フォルダの日付
    Dim folderTime As String
    '判定フラグ
    Dim makeFolderFlag As Boolean
    
    'year
    Dim yearfolder As Outlook.Folder
    
    'month
    Dim monthfolder As Outlook.Folder
    
    'date
    Dim datefolder As Outlook.Folder
    
    Set oApp = CreateObject("Outlook.Application")
    
    ' NameSpace オブジェクトへの参照を取得します。
    Set oNamespace = oApp.GetNamespace("MAPI")
    
    Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox) '規定のフォルダー olFolderInbox=6 指定
    
    '受信トレイ直下のアイテム・メールの件名を表示
    'メール数分ループ
    countNum = oFolder.Items.count
    
    For n = countNum To 1 Step -1 'アイテム数分ループ
    
        Set mITEM = oFolder.Items(n)
        
        '受信時間
        folderDateTime = mITEM.ReceivedTime
        folderTime = Split(folderDateTime, " ")(0)
        
        nen = Split(folderTime, "/")(0)
        tuki = Split(folderTime, "/")(1)
        hi = Split(folderTime, "/")(2)
        
        'フォルダの存在チェック(年フォルダ)
        For Each num In oFolder.Folders
            
            ' フォルダがあったら作らない
            If nen = num Then
            
                makeFolderFlag = True
                Exit For
                
            End If
        
        Next
        
        'フォルダを作成する必要がある場合
        If makeFolderFlag = False Then
            '受信フォルダ直下に日付のフォルダを作成する。
            Set yearfolder = oFolder.Folders.Add(nen)
        Else
            '受信フォルダ直下に日付のフォルダを取得する。
            Set yearfolder = oFolder.Folders(nen)
        End If
        
        '初期化
        makeFolderFlag = False
        
        'フォルダの存在チェック(月フォルダ)
        For Each num In yearfolder.Folders
            
            ' フォルダがあったら作らない
            If tuki = num Then
            
                makeFolderFlag = True
                Exit For
                
            End If
        
        Next
        
        'フォルダを作成する必要がある場合
        If makeFolderFlag = False Then
            '受信フォルダ直下に日付のフォルダを作成する。
            Set monthfolder = yearfolder.Folders.Add(tuki)
        Else
            '受信フォルダ直下に日付のフォルダを取得する。
            Set monthfolder = yearfolder.Folders(tuki)
        End If
        
        '初期化
        makeFolderFlag = False
        
        'フォルダの存在チェック(日フォルダ)
        For Each num In monthfolder.Folders
            
            ' フォルダがあったら作らない
            If hi = num Then
            
                makeFolderFlag = True
                Exit For
                
            End If
        
        Next
        
        'フォルダを作成する必要がある場合
        If makeFolderFlag = False Then
            '受信フォルダ直下に日付のフォルダを作成する。
            Set datefolder = monthfolder.Folders.Add(hi)
            Set sono1 = datefolder.Folders.Add("sono1")
            Set sono2 = datefolder.Folders.Add("sono2")
            Set etcFolder = datefolder.Folders.Add("etc")
            
        Else
        
            '受信フォルダ直下に日付のフォルダを取得する。
            Set datefolder = monthfolder.Folders(hi)
            Set artfolder = datefolder.Folders("sono1")
            Set peacockfolder = datefolder.Folders("sono2")
            Set etcFolder = datefolder.Folders("etc")
            
        End If
        
        'その1からの場合(件名にその1)
        If InStr(mITEM.Subject, "その1") > 0 Then
            'メールの移動
            oFolder.Items(n).Move sono1
        
        'その2からの場合
        ElseIf InStr(mITEM.Subject, "その2") > 0 Then
            'メールの移動
            oFolder.Items(n).Move sono2
            
        'そのほか
        Else
            'メールの移動
            oFolder.Items(n).Move etcFolder
        End If
        
        'オブジェクト解放
        Set sono1 = Nothing
        Set sono2 = Nothing
        set etcFolder = Nothing
        
        makeFolderFlag = False
        
    Next
    
    '使用したオブジェクトの解放　= Nothing
    Set mITEM = Nothing
    Set subFolder = Nothing
    Set oFolder = Nothing
    Set oNamespace = Nothing

End Sub

ThisOutlookSessionで以下を記載

ThisOutlookSession

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
        Call deliver.mailFuriwake
End Sub

後は勝手に振り分けてくれる。ソースは汚いけど個人的に便利

フォルダの階層的には、
/2016/05/11/sono1/対象のメール
/2016/05/11/sono2/対象のメール
/2016/05/11/etc/対象のメール
といった感じで振り分けてくれる。

対象のメールが増えたら、改修しなきゃだけど、こっちの方が好きかな。日付ごとになるし。