添付ファイルを指定の場所に自動で保存させたい！

seikyuu@xxxxx.jp宛に届いたメールの添付ファイルが指定のフォルダに保存されない

5月　テスト　㈱xxxxx　￥100,000 .pdf
2024.5.31　テスト　㈱xxxxx　￥100,000.pdf
2024531　テスト　㈱xxxxx　￥100,000.pdf
R6.5　テスト　㈱xxxxx　￥100,000.pdf
令和6年5月　㈱xxxxx　￥100,000 .pdf

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim arr() As String
    Dim i As Integer
    Dim olNs As Outlook.NameSpace
    Dim itm As Object
    Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient

    Set olNs = Application.GetNamespace("MAPI")
    arr = Split(EntryIDCollection, ",")

    For i = 0 To UBound(arr)
        Set itm = olNs.GetItemFromID(arr(i))

        If itm.Class = olMail Then
            ' 受信者アドレスをチェック
            Set recips = itm.Recipients
            For Each recip In recips
                If recip.Address = "seikyuu@xxxxx.jp" Then
                    If itm.Attachments.Count > 0 Then
                        SaveAttachmentsToFolder itm
                    End If
                    Exit For
                End If
            Next recip
        End If
    Next

    Set olNs = Nothing
    Set itm = Nothing
End Sub

Sub SaveAttachmentsToFolder(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim folderName As String
    Dim folderPath As String
    Dim fs As Object

    ' 保存先フォルダを指定
    saveFolder = "\\xxxxx\xxxxx\☆請求相殺入力台帳\請求書保管\"

    ' FileSystemオブジェクトを作成
    Set fs = CreateObject("Scripting.FileSystemObject")

    ' 添付ファイルを保存
    For Each objAtt In itm.Attachments
        ' ファイル名から日付を取得
        folderName = GetDateFromFileName(objAtt.fileName)
        ' フォルダパスを作成
        folderPath = saveFolder & IIf(folderName = "", "その他", "R" & Format(DateValue(folderName), "y.m")) & "\"
        ' フォルダが存在しない場合は作成
        If Not fs.FolderExists(folderPath) Then
            fs.CreateFolder folderPath
        End If
        ' 添付ファイルを保存
        objAtt.SaveAsFile folderPath & objAtt.fileName
    Next objAtt

    ' 解放
    Set objAtt = Nothing
    Set fs = Nothing
End Sub

Function GetDateFromFileName(fileName As String) As String
    Dim matches As Object
    Dim regex As Object
    Dim match As Object
    Dim datePattern As String
    Dim year As Integer
    Dim month As Integer
    Dim day As Integer

    ' 正規表現パターン
    datePattern = "(\d{4}-\d{1,2}-\d{1,2})|(令和[0-9]+年[0-9]+月)" ' 「yyyy-m-d」または「令和6年5月」の形式にマッチするパターン

    ' 正規表現オブジェクトを作成
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = False
    regex.Pattern = datePattern

    ' ファイル名から日付を抽出
    If regex.test(fileName) Then
        Set matches = regex.Execute(fileName)
        For Each match In matches
            If Left(match.Value, 1) = "令" Then
                ' 「令和6年5月」から年と月を取得
                year = CInt(Mid(match.Value, 3, InStr(match.Value, "年") - 3))
                month = CInt(Mid(match.Value, InStr(match.Value, "年") + 1, InStr(match.Value, "月") - InStr(match.Value, "年") - 1))
                ' 和暦を西暦に変換
                year = year + 2018 ' 令和元年は2018年
                GetDateFromFileName = year & "-" & month & "-01" ' 日は1日として固定
            Else
                ' 「yyyy-m-d」から年、月、日を取得
                GetDateFromFileName = match.Value
            End If
            Exit Function ' 最初にマッチした日付を使用するため、ループを抜ける
        Next match
    Else
        GetDateFromFileName = ""
    End If
End Function