Outlookで選択したアイテムを任意のフォルダ作成して格納したい

表題通り。普段メーラーはOutlookを使っている。ファイルを別ディレクトリの中に分別して格納することがあるのだが、これを自動化した。

Sub sample()

 '   Application.ScreenUpdating = False

    Dim path As String
    Dim fso As Object
    Dim sunday As Date
    Dim monday As Date
    Dim foldername As String
    Dim inumber As Integer
    Dim i As Integer
    'Dim oFolder As Outlook.Folder 'フォルダ
    Dim nowitem As MailItem 'メールアイテム
    Dim nowdate As String
    Dim nowsbjct As String
    Dim ary As Variant '不可文字削除用配列
    Dim r As Integer
    Dim flname As String
    Dim PathAry As Variant 'path用配列

    Dim outlookObj As Outlook.Application 'サブフォルダの設定
    Dim myNameSpace, objmailItem As Object
    Dim InboxFolder, subfolder As Long


'    Set outlookObj = CreateObject("Outlook.Application")
'    Set myNameSpace = outlookObj.GetNamespace("MAPI")
'    Set InboxFolder = myNameSpace.GetDefaultFolder(6)
'    Set subfolder = InboxFolder.Folders("******")



    ary = Array("RE: ", "FW: ", "\", "/", ":", "*", "?", "<", ">", "|", """", "[", "]", ",")

    'Date減算
    monday = now - 7
    sunday = now - 1


    foldername = Format(monday, "yyyy年mm月dd日") & "～" & Format(sunday, "yyyy年mm月dd日")
'    Debug.Print foldername

    Set fso = CreateObject("Scripting.FileSystemObject") 'フォルダを作成するための専用のオブジェクト(インスタンス)
'
'
    PathAry = Array("test", "\test", "\test", "\test", "\test", "test", "\", "")
    PathAry(UBound(PathAry)) = foldername

' 
    path = Join(PathAry, "")

    'Debug.Print path
    fso.CreateFolder path 'フォルダの作成


'
    inumber = Application.ActiveExplorer.Selection.Count '選択中のアイテム数を取得

    'Debug.Print inumber

    For i = 0 To inumber - 1 
'
        Set nowitem = Application.ActiveExplorer.Selection.Item(i + 1) 'i番目のアイテムの定義
'
        nowsbjct = nowitem.Subject '件名（？）
        'nowdate = nowitem.ReceivedTimeここは関係ない

        'Debug.Print nowsbjct

        For r = 0 To UBound(ary)
            nowsbjct = Replace(nowsbjct, ary(r), "")
        Next r

        flname = nowsbjct & ".msg" 'ファイル名生成

'        Debug.Print flnam　　　　

        'nowitem.SaveAs path & flname, olMSG

        nowitem.SaveAs path & "\" & flname, olMSG 'ファイル保存




    Next i

        Set fso = Nothing
        Set nowitem = Nothing

End Sub