AccessVBAにてファイル入出力ダイアログを表示

まだAccessでマッチョにコードを書き始める前は
Accessでファイル入出力ダイアログを呼ぶときに、microsoftOfficeやExcelのオブジェクトを参照設定して呼び出しいました。

だけれど、それだとOfficeのバージョンが開発環境と異なる場合にエラーになっちゃうんですね。
そこで、あれこれ調べていると隠しオブジェクトのWizHookを使うことによって
参照設定無しでダイアログが呼べることを発見。

以下はダイアログの関数。戻り値はファイルパス。

※下記のソースを使用する場合はあくまで自己責任になります。

'=============================================================================================================
Function GetFileName(Optional hwndOwner As Long, Optional AppName As String, Optional DlgTitle As String, _
                       Optional OpenTitle As String, Optional strFile As String, Optional InitialDir As String, _
                       Optional Filter As String, Optional FilterIndex As Long, Optional View As F_gnfView, _
                       Optional flags As F_gfnFlags, Optional fOpen As F_gfnFOpen = gfnFOpenOpen) As String
'◆機能 :   コモンダイアログ呼び出し(「ファイルを開く」、「名前をつけて保存」)
'◆引数 :   hwndOwner   =ダイアログのオーナーとなるオブジェクトのハンドルを渡します。
'           AppName     =実行アプリケーションの名前を指定します。
'           DlgTitle    =ダイアログのウィンドウタイトルに表示する文字列を指定します。
'                        省略時は既定のタイトル(「ファイルを開く」あるいは「名前を付けて保存」)が表示されます。
'           OpenTitle   =実行用コマンドボタンの標題に当たる文字列を指定します。
'                        省略時は既定の標題（「開く」あるいは「保存」）が表示されます。
'           strFile     =出力用引数です。選択したファイルのフルパスが格納されます。
'           InitialDir  =ダイアログの初期表示ディレクトリを指定します。
'                        省略時はカレントディレクトリが表示されます。
'           Filter      =[ファイルの種類] リストボックスに設定する一覧を指定します。
'                        形式は「表示用文字列 1|拡張子 1|表示用文字列 2|拡張子 2|...」の繰り返しになります。
'                        区切り記号「|」は Chr$(0) あるいは定数 vbNullChar でも構いませんが、
'                        VB では「|」を使った方が簡単でしょう。
'                        なお表示用文字列の中の拡張子を括る括弧を誤って全角文字で指定すると､実行されません｡
'           FilterIndex =初期表示時に [ファイルの種類] リストボックスの何行目を既定で選択するかをインデックス番号で指定します。
'                        先頭行は 0 から開始します。
'           View        =ファイル一覧の表示スタイルを指定します。
'                        0=詳細、1=プレビュー、2=プロパティ、3=一覧です。
'                        View 引数は単独では機能せず、flags 引数に &H40 を指定して初めて有効になります。
'           flags       =ダイアログの動作を指定するオプション値をビットフラグで指定します。
'                        これは Win32 API で使用される OPENFILENAME 構造体の Flags と微妙に異なります。
'                        現時点で判明しているオプションについては､参考資料を参照
'                 View = 0 , flags = 0  : Viewを直前に実行したタイプと同じにする
'                 View = 0 , flags = 64 : [詳細]
'                 View = 1 , flags = 64 : [プレビュー]
'                 View = 2 , flags = 64 : [プロパティ]
'                 View = 3 , flags = 64 : [一覧]
'                 View = 0 , flags = 32 , fOpen = True : フォルダ選択モード
'                 View = 0 , flags = 1  , fOpen = False : 読み取り専用ファイルの選択を不可にし、上書き確認
'                 View = 0 , flags = 8  , fOpen = True  : 複数ファイル選択可。ファイル名間はタブで区切られる
'           fOpen       =ダイアログの種別を指定します。
'                        True を設定すると [ファイルを開く] になり、
'                        False を指定すると [名前を付けて保存] になります。
'◆戻値 :  ファイルが選択された場合はそのファイルのパス名(strFile)、キャンセルされた場合は空文字("")
'=============================================================================================================
    Dim lngResult As Long
    
    '初期化
    If hwndOwner = 0 Then
        hwndOwner = Application.hWndAccessApp
    End If
    
    If AppName = "" Then
        AppName = "Microsoft Access"
    End If
    
    If Filter = "" Then
        Filter = "すべてのファイル (*.*)|*.*"
    End If
    
    'WizHook 有効化
    WizHook.Key = 51488399
    'WizHook の GetFileName を呼び出し
    lngResult = WizHook.GetFileName(hwndOwner, AppName, DlgTitle, OpenTitle, strFile, InitialDir, Filter, FilterIndex, View, flags, fOpen)
    ' WizHook 無効化
    WizHook.Key = 0

    If lngResult = -302 Then
        F_GetFileName = ""
    Else
        F_GetFileName = strFile
    End If
End Function

そんでもって、下記はinputboxに入力した名前にてテーブルを生成しつつ任意のcsvファイル取り込むコード

Sub testcode()

Dim cn As New ADODB.Connection
Dim cn2 As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim str_sql As String
Dim file_name As String
Dim Update_Date As Date
Dim DAO As DAO.Database
Dim tdfNew As TableDef
Dim drs As DAO.Recordset
Dim count As Integer
Dim i As Integer
Dim ck_flg As Boolean
Dim path As String
Dim tmp_path As String
Dim Array_file_name As Variant
Dim FNo As Long
Dim txtData As String
Dim tb_name As String

Set cn = CurrentProject.Connection



 'ファイル名を取得
 tmp_path = get_tmp_path()
    file_name = GetFileName(0, _
                        "" & "", _
                        "取込", _
                        "取込", _
                        "", _
                        Nz(tmp_path, ""), _
                        gfnFilter_csv, _
                        0, _
                        gfnViewDetail, _
                        8, _
                        gfnFOpenOpen)
    '--2-2.ファイルの出力
    file_name = Replace(file_name, Chr(9), ",")
  Array_file_name = Split(file_name, ",")
                                                            
    If Trim(Array_file_name(0)) <> "" Then 'ファイル名が未選択か
        path = GetPath(Array_file_name(0)) 'パス名の取得
        Call set_tmp_path(path)
               
    Else
    
         Exit Sub
    End If
    

'一行目を読み込む
FNo = FreeFile
tb_name = InputBox("テーブル名を決めてください", "入力")


Open file_name For Input As #FNo
    'ファイルの1行目の項目名部分を読み込む
    'フォーマットチェック
    Line Input #FNo, txtData
    arrData = Split(txtData, ",")


        '新しい TableDef オブジェクトを作成します。
    Set db = CurrentDb
        Set tdfNew1 = db.CreateTableDef(tb_name)


            ' フィールドを作成し、新しい TableDef オブジェクトに追加します。
            ' これは、TableDef オブジェクトを このデータベース上の
            'TableDefs コレクションに追加する前に行う必要があります。

For i = 0 To UBound(arrData)
    tdfNew1.Fields.Append tdfNew1.CreateField(arrData(i), dbText, 255)

Next i
            ' 新しい TableDef オブジェクトをデータベースに追加します｡
            db.TableDefs.Append tdfNew1


    Set db = Nothing
    Set tdfNew = Nothing

'w1取込
rs.Open tb_name, cn, adOpenDynamic, adLockOptimistic
        '実際のデータ部分(2行目)からの処理
        Do While Not EOF(FNo)
            Line Input #FNo, txtData    '行単位
            arrData = Split(txtData, ",")
            
            If rs.Fields(0).Name = arrData(0) Then 'フィールド名=データの値なら取り込まない

            
            Else
                rs.AddNew
                    For i = 0 To UBound(arrData)
                            If Nz(arrData(i), "") = "" Then
                                rs.Fields(i) = Null
                            Else
                                rs.Fields(i) = Replace(arrData(i), """", "")
                            End If
                    Next i
                rs.Update
            End If
        Loop
           
    Close #FNo

    Set rs = Nothing


End Sub