選択中のアイテムを受信時刻と件名のファイル名で保存する: Outlook VBA

Option Explicit On
' 参照設定 '
' Microsoft Scriptiong Runtime '
' Microsoft Excel 15.0 Object Library ' 

Sub Macro_選択中のアイテムを受信時刻と件名のファイル名で保存する()

    Dim wnd As Window
    Dim exp As Explorer
    Set exp = ActiveExplorer
    Dim hwnd As Long
    hwnd = FindWindow("rctrl_renwnd32", exp.Caption)

    ' 保存先選択'
    Dim oExcel As New Excel.Application
    oExcel.Visible = False
    Dim DiagFol As Office.FileDialog
    Set DiagFol = oExcel.Application.FileDialog(msoFileDialogFolderPicker)
    DiagFol.Show
    Dim PathSaveAs As String
    PathSaveAs = DiagFol.SelectedItems(1) & "\" '"
    oExcel.Quit
    Set oExcel = Nothing
 
    ' 添付を保存するかどうか。'
    Dim diagRes As VbMsgBoxResult
    Dim AttachFileSaveAs As Boolean
    diagRes = MsgBox("選択したメールアイテムに添付ファイルがある場合，" & vbCrLf & "それぞれの添付ファイルを個別のファイルとして保存" & vbCrLf & "しますか？（Yes/No）" & vbCrLf & "処理を中止する場合はキャンセル", vbYesNoCancel, "確認")
    If diagRes = vbCancel Then
        Exit Sub
    ElseIf diagRes = vbNo Then
        AttachFileSaveAs = False
    ElseIf diagRes = vbYes Then
        AttachFileSaveAs = True
    End If

    ' メール保存'
    Dim objItem As MailItem
    Dim numItem As Integer
    Dim countItem As Integer

    ' 現在選択中のアイテムすべてについて'
    countItem = ActiveExplorer.Selection.Count
    For numItem = 1 To countItem
        Call ChangeStatusBarText(hwnd, "メール保存中(" & numItem & "/" & countItem & ")")
        DoEvents
        If ActiveExplorer.Selection.Item(numItem).Class = OlObjectClass.olMail Then
            Set objItem = ActiveExplorer.Selection.Item(numItem)
        Else
            GoTo CNT
        End If
        Dim fnTimestamp As String
        Dim strFileName As String
        On Error Resume Next
        fnTimestamp = Format(objItem.ReceivedTime, "yyyy.mm.dd-hhnn_")
        If Err.Number <> 0 Then
            ' エラーが発生したら受信日時ではなく最終更新日時とする'
            fnTimestamp = Format(objItem.LastModificationTime, "yyyy.mm.dd-hhnn_")
            Err.Clear
        End If
        On Error GoTo 0
        ' ファイル名を受信日時と件名から作成'
        strFileName = fnTimestamp & objItem.Subject
        ' ファイルをフォルダに保存'
        objItem.SaveAs FixFileName(PathSaveAs, strFileName, "msg"), olMSG
        ' 添付ファイルの処理'
        If AttachFileSaveAs Then
            Dim objAttach As Attachment
            Dim numAttach As Integer
            Dim countAttach As Integer
            countAttach = objItem.Attachments.Count
            If countAttach > 0 Then
                For numAttach = 1 To countAttach
                    Call ChangeStatusBarText(hwnd, "メール保存中(" & numItem & "/" & countItem & ") → 添付ファイルを保存中(" & numAttach & "/" & countAttach & ")")
                    Set objAttach = objItem.Attachments.Item(numAttach)
                    objAttach.SaveAsFile FixFileName(PathSaveAs, fnTimestamp & objAttach.FileName)
                Next
            End If
        End If
CNT:
    Next
    Call ChangeStatusBarText(hwnd, "")
    Call DestroyStat(hwnd)

End Sub

Private Function FixFileName(path As String, name As String, Optional ext As String = "")
    Dim strFileName As String
    Dim arrErrChars
    Dim arrRepChars
    Dim objFSO As New FileSystemObject
    Dim I As Integer
    arrErrChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|") '"
    arrRepChars = Array("￥", "／", "：", "＊", "？", "_", "＜", "＞", "｜")
    Const MAX_PATH = 259
    ' Extなし'
    If ext = "" Then
        ext = objFSO.GetExtensionName(name)
        name = objFSO.GetBaseName(name)
    End If
    ' ファイル名として不適切な文字を置き換える'
    strFileName = name
    For I = 0 To UBound(arrErrChars)
        strFileName = Replace(strFileName, arrErrChars(I), arrRepChars(I))
    Next
    ' ファイル名が 260 文字以上とならないようにする。'
    strFileName = Left(path & strFileName, MAX_PATH - Len(ext) - 1)
    Dim idx As String
    Dim tmpFileName As String
    tmpFileName = strFileName
    ' 同名のファイルがある場合の処理'
    If objFSO.FileExists(tmpFileName & "." & ext) Then
        I = 2 ' (2) から始める'
        idx = "(" & I & ")"
        tmpFileName = Left(strFileName, MAX_PATH - Len(ext) - 1 - Len(idx)) & idx
        While objFSO.FileExists(tmpFileName & "." & ext)
            I = I + 1
            idx = "(" & I & ")"
            tmpFileName = Left(strFileName, MAX_PATH - Len(ext) - 1 - Len(idx)) & idx
        Wend
    End If
    FixFileName = tmpFileName & "." & ext
End Function