【Access VBA】Outlookの指定フォルダ配下のメールをPCの指定フォルダに保存する

If SaveMailItemBodyFromOutlookFolder("OutLookFolderes","number_info_In","Tools_Data_Temp\accdb","number_info_Out")>0 Then
メッセージボックス ("number_info_In" 配下のメールの保存に失敗しました。,はい,なし) 
If 文の最後

Function SaveMailItemBodyFromOutlookFolder(ByVal table_name As String, ByVal in_folder_name As String, ByVal out_path As String, Optional ByVal out_folder_name As String) As Integer
    
    ' 成功コードと失敗コードを定数として設定する
    Const C_SUCCESS As Integer = 0
    Const C_FAILURE As Integer = 1
    
    ' 必要な変数を宣言する
    Dim myNamespace As Object
    Dim inFolder As Object
    Dim outFolder As Object
    Dim currentFolder As Object
    Dim mailItem As Object
    
    Dim yyyymmddhhmmss As String
    Dim fullpath As String
    
    Dim mailItemsToProcess As Collection
    Set mailItemsToProcess = New Collection
    
    On Error GoTo ErrorHandler
    
    ' Outlook アプリケーションおよび名前空間オブジェクトを作成する
    Set myNamespace = CreateObject("Outlook.Application").GetNamespace("MAPI")
    
    ' 入力フォルダーをフォルダーパスを解析して取得する
    Set inFolder = getOutlookFolder(table_name, in_folder_name, myNamespace)
    
    ' 出力フォルダーが指定されている場合は取得する
    If Not out_folder_name = "" Then
        Set outFolder = getOutlookFolder(table_name, out_folder_name, myNamespace)
    End If
    
    ' 出力先のパスを設定する
    fullpath = Environ("UserProfile") & "\" & out_path & "\"
    
    ' 処理するメールアイテムのコレクションを作成する
    For Each mailItem In inFolder.Items
        mailItemsToProcess.Add mailItem
    Next mailItem
    
    ' メールアイテムコレクションの各メールアイテムに対して処理を実行する
    For Each mailItem In mailItemsToProcess
        Debug.Print inFolder.Items.Count
        ' メールの送信日に基づいて一意なファイル名を生成する
        yyyymmddhhmmss = in_folder_name & "_" & Format(mailItem.SentOn, "yyyymmddhhmmss")
        
        ' テキストファイルを作成し、メールの本文を書き込む
        Open fullpath & yyyymmddhhmmss & ".txt" For Output As #1
        Print #1, mailItem.Body
        Close #1
        
        ' 出力フォルダーが指定されている場合はメールを移動する
        If Not out_folder_name = "" Then
            mailItem.Move outFolder
        End If
        
    Next mailItem
    
    ' オブジェクトを解放する
    Set mailItem = Nothing
    Set outFolder = Nothing
    Set inFolder = Nothing
    Set myNamespace = Nothing
    
    ' 成功コードを返す
    SaveMailItemBodyFromOutlookFolder = C_SUCCESS
    
ExitFunction:
    Exit Function
    
ErrorHandler:
    Debug.Print Err.Description
    ' エラーが発生した場合はオブジェクトを解放し、失敗コードを返す
    Set mailItem = Nothing
    Set outFolder = Nothing
    Set inFolder = Nothing
    Set myNamespace = Nothing
    
    ' 失敗コードを返す
    SaveMailItemBodyFromOutlookFolder = C_FAILURE
    Resume ExitFunction
    
End Function

Function getOutlookFolder(ByVal table_name As String, ByVal folder_path As String, ByVal my_name_space As Object) As Object
    
    Dim fullPathOfOutlookFolder As String
    fullPathOfOutlookFolder = getFullPathOfOutlookFolder(table_name, folder_path)
    
    ' フォルダーパスをバックスラッシュで分割する
    Dim strArray() As String
    strArray = Split(fullPathOfOutlookFolder, "\")
    ' フォルダーオブジェクトを取得する
    Dim currentFolder As Object
    Set currentFolder = my_name_space.Folders(strArray(0)).Folders(strArray(1))
    Dim index As Integer
    For index = 3 To UBound(strArray)
        Set currentFolder = currentFolder.Folders.Item(strArray(index))
    Next index
    ' 取得した Outlook フォルダーを返す
    Set getOutlookFolder = currentFolder
End Function

Public Function getFullPathOfOutlookFolder(ByVal reference_table_name As String, ByVal key_word As String) As String
    ' 変数を宣言する
    Dim intIndex As Integer
    Dim fullPathOfOutlookFolder As String
    
    ' エラーハンドリング
    On Error GoTo exitWithFailure
    
    ' fullPathOfOutlookFolder変数を初期化する
    fullPathOfOutlookFolder = ""
    
    ' レコードセットオブジェクトを作成し、テーブルを開く
    Dim tableName As New ADODB.Recordset
    tableName.Open reference_table_name, CurrentProject.Connection
    
    ' テーブル内のレコードを検索し、キーワードに一致するパスを取得する
    Do Until tableName.EOF
        ' パスの初期化
        fullPathOfOutlookFolder = tableName!accountName & "\" & tableName!InboxName & "\" & tableName!NumberOfSubFolders
        
        ' サブフォルダの列をループして、レコードを追加する
        For intIndex = 1 To tableName!NumberOfSubFolders
            ' サブフォルダのパスを追加
            fullPathOfOutlookFolder = fullPathOfOutlookFolder & "\" & tableName.Fields("SubFolder" & CStr(intIndex)).Value
            
            ' キーワードが含まれている場合、パスを返してループを終了する
            If InStr(fullPathOfOutlookFolder, key_word) > 0 Then
                getFullPathOfOutlookFolder = fullPathOfOutlookFolder
                Exit Do
            End If
        Next intIndex
    
        ' 次のレコードに移動する
        tableName.MoveNext
    Loop
    
    ' レコードセットを閉じる
    tableName.Close
    
    ' 関数からパスを返す
    Exit Function
   
exitWithFailure:
    ' fullPathOfOutlookFolder変数を返す
    getFullPathOfOutlookFolder = fullPathOfOutlookFolder
End Function