【OutlookVBA】選択中のメールをmsgファイル保存

Outlookでよくメールをmsgファイルの保存します。ファイル名先頭には日時を付けてます。
日時はメールの以下の部分から取得しています。

５個くらいまでなら手動でもいいんですが、１０個くらいになると「なんか自動化できないかなー」という思いに駆られます。
ということでVBAを作りました。

■動作

出力対象のメールを選択します。
※複数選択可

「選択中のメールをファイル保存」マクロを実行します。

マクロ内で設定しているパスにメールがmsgファイルで保存されます。
ファイル形式は「yyyymmdd_hhmmss_[件名].msg」

■ソース

※使用する場合、定数のOUTPUT_PATHは好みの場所に変更してください。

'**************************************************************
'* モジュール名：
'* 概要：選択中のメールをファイル保存する
'* 備考：
'***************************************************************
Option Explicit

' ファイル保存先
Private Const OUTPUT_PATH = "C:\Users\[user_id]\Desktop"

Private Const REMOVE_STR = "[\\/:*?""'<>|]"   ' パスから除去する文字列
Private fso As FileSystemObject

'**************************************************************
'* 関数名：選択中のメールをファイル保存
'* 概要：選択中のメールをファイル保存する
'* 使い方：
'* パラメータ ：(I) なし
'* 戻り値     ：なし
'***************************************************************
Public Sub 選択中のメールをファイル保存()
    
    Dim objOL As Outlook.Application
    Dim objOLSelect As Outlook.Selection
    Dim item As MailItem
    Dim i As Long, j As Long, k As Long
    Dim spathsave As String
    Dim filepath As String
      
    Set objOL = New Outlook.Application
    Set objOLSelect = objOL.ActiveExplorer.Selection
    Set fso = New FileSystemObject
    
    ' [ 選択中のメールに対してループ ]
    For k = 1 To objOLSelect.count
        ' メールを取得
        Set item = objOLSelect.item(k)
    
        Debug.Print item.Subject
    
        ' 同じ年月日時分秒で同じ件名のメールがあった場合の対応。末尾に「 (n)」の文字列を付ける
        For j = 0 To 1000
            ' 0：まずは同じ年月日時分秒で同じ件名のメールがない想定
            If j = 0 Then
                ' ファイルパス作成
                filepath = fso.BuildPath(OUTPUT_PATH, Format(item.ReceivedTime, "yyyymmdd_hhmmss") & "_" & RegExpReplace(item.Subject, REMOVE_STR, "") & ".msg")
            Else
                ' 括弧付のファイルパス作成
                filepath = fso.BuildPath(OUTPUT_PATH, Format(item.ReceivedTime, "yyyymmdd_hhmmss") & "_" & RegExpReplace(item.Subject, REMOVE_STR, "") & " (" & j & ").msg")
            End If

            ' ファイルがないなら保存する
            If fso.FileExists(filepath) = False Then
                item.SaveAs filepath
                Exit For    ' j ループ終了
            End If
        
            If j = 1000 Then
                MsgBox "同じ年月日時分秒で同じ件名が1000件！さすがにここには来ないはず"
            End If
        Next j
    Next k
End Sub

'**************************************************************
'* 関数名：RegExpReplace
'* 概要：正規表現置換
'* 使い方：
'* パラメータ ：(I)文字列
'*            ：(I)正規表現パターン
'*            ：(I)置換後文字列
'* 戻り値     ：変換後文字列
'***************************************************************
Private Function RegExpReplace(s1 As String, sPattern As String, sReplaceStr As String)
    Dim oRegExp As RegExp
    Set oRegExp = New RegExp
    oRegExp.Pattern = sPattern                      ' 正規表現パターン
    oRegExp.IgnoreCase = False                      ' 大文字小文字を区別
    oRegExp.Global = True                           ' 複数マッチオン
    RegExpReplace = oRegExp.Replace(s1, sReplaceStr)    ' 置換
End Function