【Access VBA】Outlookのフォルダ名を保存するテーブルを自動生成する

If MakeFolderNameTableForOutlook("OutLookFolderes")>0 Then
メッセージボックス ("OutLookFolderes" の作成に失敗しました。,はい,なし) 
If 文の最後

Function MakeFolderNameTableForOutlook(table_name As String) As Integer
    ' 成功、失敗の定数の定義
    Const C_SUCCESS As Integer = 0
    Const C_FAILURE As Integer = 1
    ' フォルダのレイヤー数、フォルダ数、フォルダ名の配列の宣言
    Dim numberOfFoldersLayers As Integer
    Dim numberOfFolders As Integer
    Dim foldersName() As Variant
    ' エラーハンドリング
    On Error GoTo exitWithFailure
    ' Outlookからフォルダプロパティを取得
    Call getFoldersPropertiesFromOutlook(numberOfFolders, numberOfFoldersLayers, foldersName)
    ' テーブル作成
    Call makeFolderNameTable(table_name, numberOfFolders, numberOfFoldersLayers, foldersName)
    ' フォルダ名をテーブルに挿入
    Call putFolderNameToFolderNameTable(table_name, numberOfFolders, numberOfFoldersLayers, foldersName)
    ' 成功を返す
    MakeFolderNameTableForOutlook = C_SUCCESS
    Exit Function
exitWithFailure:
    ' 失敗を返す
    MakeFolderNameTableForOutlook = C_FAILURE
End Function

Sub getFoldersPropertiesFromOutlook(ByRef number_of_folders As Integer, ByRef number_of_folders_layer As Integer, ByRef folder_name As Variant)
' OutlookのApplicationオブジェクトとNamespaceオブジェクトを宣言
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.Namespace
' Outlookのアカウントとフォルダを宣言
Dim objAccount As Outlook.Account
Dim objInbox As Outlook.Folder
' エラーハンドリング
On Error GoTo exitWithFailure
' 取得したフォルダ名を格納する配列を宣言
ReDim folder_name(0 To 100)
' 取得するフォルダの階層数を初期化
number_of_folders_layer = 1
' 取得するフォルダの数を初期化
number_of_folders = 0
' OutlookのApplicationオブジェクトとNamespaceオブジェクトを設定
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
' すべてのアカウントに対して処理を繰り返す
For Each objAccount In objNamespace.Accounts
    
    ' 現在のアカウントのInboxフォルダを取得する
    Set objInbox = objNamespace.Folders(objAccount.DeliveryStore.DisplayName).Folders("受信トレイ")
    
    ' 取得したフォルダのプロパティを取得する
    Call getFolders(objInbox, number_of_folders, number_of_folders_layer, folder_name)
    
Next objAccount
' 取得したフォルダ名を格納する配列のサイズを更新
ReDim Preserve folder_name(0 To number_of_folders)
exitWithFailure:
    
' クリーンアップ
Set objOutlook = Nothing
Set objNamespace = Nothing
End Sub

Sub getFolders(ByVal objParentFolder As Outlook.Folder, ByRef number_of_folders As Integer, ByRef number_of_layer As Integer, ByRef folder_name As Variant)
    Dim objSubfolder As Outlook.Folder
    Dim intCurrentLayers As Integer
    
    number_of_folders = number_of_folders + 1
    folder_name(number_of_folders) = objParentFolder.FolderPath
    ' 全てのサブフォルダに対して再帰的にフォルダ名を取得する
    For Each objSubfolder In objParentFolder.Folders
        ' 現在のフォルダの深さを計算する
        intCurrentLayers = countCharacter(objSubfolder.FullFolderPath, "\") - 1
        Debug.Print objSubfolder.FullFolderPath, intCurrentLayers
        ' 最大の深さを記録する
        If number_of_layer < intCurrentLayers Then number_of_layer = intCurrentLayers
        ' サブフォルダに再帰的にフォルダ名を取得する
        Call getFolders(objSubfolder, number_of_folders, number_of_layer, folder_name)
        
    Next objSubfolder
End Sub

Function countCharacter(ByVal input_string As String, ByVal input_character As String) As Integer
     
    countCharacter = Len(input_string) - Len(Replace(input_string, input_character, ""))
 
End Function

Sub makeFolderNameTable(ByVal table_name As String, ByRef number_of_folders As Integer, ByRef number_of_folders_layer As Integer, ByRef folder_name As Variant)
    ' 変数の宣言
    Dim newTable As DAO.TableDef
    Dim dataAccessObject As DAO.Database
    Dim tableDefinition As Variant
    Dim index As Integer
    ' エラーハンドリング
    On Error GoTo exitWithFailure
    ' Accessデータベースの取得
    Set dataAccessObject = CurrentDb
    ' テーブルの存在確認と削除
    For Each tableDefinition In dataAccessObject.TableDefs
        If (tableDefinition.Name = table_name) Then
            DoCmd.DeleteObject acTable, tableDefinition.Name
        End If
    Next
    ' テーブルの作成
    Set newTable = dataAccessObject.CreateTableDef(Name:=table_name)
    ' フィールドの追加
    With newTable.Fields
        .Append newTable.CreateField("AccountName", dbText)
        .Append newTable.CreateField("InboxName", dbText)
        .Append newTable.CreateField("NumberOfSubFolders", dbInteger)
        For index = 3 To number_of_folders_layer
            .Append newTable.CreateField("SubFolder" & CStr(index - 2), dbText)
        Next index
    End With
    ' テーブルの追加とクローズ
    dataAccessObject.TableDefs.Append newTable
    dataAccessObject.Close
    
    ' Accessデータベースウィンドウの更新
    Application.RefreshDatabaseWindow
exitWithFailure:
    ' 変数の解放
    Set newTable = Nothing
    Set dataAccessObject = Nothing
End Sub

Sub putFolderNameToFolderNameTable(ByVal table_name As String, ByRef number_of_folders As Integer, ByRef number_of_folders_layer As Integer, ByRef folder_name As Variant)
    ' ADODB.ConnectionとADODB.recordSetを宣言
    Dim adodbConnestion As New ADODB.Connection
    Dim recordSet As New ADODB.recordSet
    ' インデックス変数の宣言
    Dim intIndexRow As Integer
    Dim intIndexColmn As Integer
    ' フォルダ名の配列、列名、列数の宣言
    Dim strAbsoluteFoldersName As String
    Dim strArray() As String
    Dim strColmnName As String
    Dim intNumberOfCulmn As Integer
    ' テーブルを開く
    Set adodbConnestion = CurrentProject.Connection
    recordSet.Open table_name, adodbConnestion, adOpenDynamic, adLockOptimistic
    ' データをループしてレコードを挿入
    For intIndexRow = 1 To number_of_folders
        strAbsoluteFoldersName = folder_name(intIndexRow)
        intNumberOfCulmn = countCharacter(strAbsoluteFoldersName, "\")
        strArray = Split(strAbsoluteFoldersName, "\")
        ' レコードの新規追加
        recordSet.AddNew
        recordSet("AccountName") = strArray(2)
        recordSet("InboxName") = strArray(3)
        recordSet("NumberOfSubFolders") = intNumberOfCulmn - 3
        ' サブフォルダの列をループしてレコードに追加
        For intIndexColmn = 4 To intNumberOfCulmn
            strColmnName = "SubFolder" & CStr(intIndexColmn - 3)
            recordSet(strColmnName) = strArray(intIndexColmn)
        Next intIndexColmn
        ' レコードの更新
        recordSet.Update
    Next intIndexRow
    ' レコードセットを閉じる
    recordSet.Close
    ' クリーンアップ
    Set recordSet = Nothing
    Set adodbConnestion = Nothing
End Sub