【Access】エクスポートするフォルダを選択指定してCSVファイルをエクスポートする方法

前回は、マイクロソフトアクセス（Accessデータベース）で、テーブルをCSVファイルでエクスポートする時に、その都度フォルダーを選択指定できる方法でエクスポートしました。

https://pctips.jp/pc-soft/access-folder-export-csv/

今回は、最初にエクスポートするフォルダーを指定してしまい、

を解説したいと思います。

テーブルとフォームを準備

その都度ダイヤログを表示させてフォルダー選択をしなくても済むように、指定したフォルダをテーブルのレコードとして保存しておく必要があります。

●テーブル作成

「export_folder」とういテーブルを作成して、フィールドには、IDとfolderというものを準備しました。

●フォーム作成

フォームの方は、最初にエクスポートするフォルダを指定する為のフォームになります。

フォルダしてのテキストボックスには、「view_folder」とう名前にしました。

フォルダ選択ボタンには、「select_folder」という名前にしました。

FunctionコードとVBAコードを設定

まずは何も考えずに、標準モジュールに下記のFunctionコードを設置しました。

'--------------------------------------------------------------------
'フォルダ選択ダイアログ
'---------------------------------------------------------------------
 
Public Function getFolderName(tmpFilePath As String) As String
 
    Dim intret As Integer
 
    With Application.FileDialog(msoFileDialogFolderPicker)
 
        'ダイアログのタイトルを設定
        .Title = "フォルダ選択ダイアログ"
 
        'デフォルトのフォルダパス
        .InitialFileName = tmpFilePath
 
        'ダイアログを表示
        intret = .Show
        If intret <> 0 Then
          'フォルダが選択されたとき戻り値に設定
          getFolderName = Trim(.SelectedItems.item(1))
        Else
          'フォルダが選択されなければ長さゼロの文字列を返す
          getFolderName = "C:\"
        End If
    End With
 
End Function

次に、フォルダ選択ボタン「select_folder」のクリック時のアクションにVBAコードを設置しました。

Private Sub select_folder_Click()

Me.view_folder = getFolderName("c:\")

Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim SQL As String
 
On Error GoTo ErrRtn

SQL = "SELECT * FROM export_folder WHERE ID = 1"
 
Set cn = CurrentProject.Connection
rs.Open SQL, cn, adOpenKeyset, adLockOptimistic
 
        cn.BeginTrans
         
        While Not rs.EOF
 
            rs!folder = view_folder
 
        rs.Update
        rs.MoveNext
        Wend
 
        cn.CommitTrans

ExitErrRtn:
    DoCmd.ShowAllRecords
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
    Exit Sub
 
ErrRtn:
    MsgBox "エラー： " & Err.description
    cn.RollbackTrans
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing

End Sub

このコードで、フォルダーをダイヤログで選択して、テキストボックス「view_folder」にフォルダーの場所を表示させます。

表示させたら、その下のコードで、「export_folder」テーブルのID＝1のフィールドの、folderフィールドに、テキストボックス「view_folder」にフォルダーの場所を書き込みします。

本当はレコードセットやエラー処理などは必要ないのかもしれませんが、いちおう対応しておきました。

フォームが開くタイミングでテーブルから読込

フォルダー選択フォーム画面を起動したときに、「export_folder」テーブルのID＝1のフィールドの、folderフィールドからフォルダーの場所を表示させる為に、下記の様なVBAを設置しました。

Private Sub Form_Open(Cancel As Integer)
    Me.view_folder = DLookup("folder", "export_folder", "ID=1")
End Sub

エクスポートボタンにVBAを設置

あとは、適当はフォームにエクスポートボタンを設置して、下記のコードを設置すれば、指定されたフォルダーにいつもエクスポートされたファイルが蓄積されることになります。

Private Sub export_btn_Click()

 Dim FolderName As String
 
 On Error GoTo ErrRtn
  
    FolderName = DLookup("folder", "export_folder", "ID=1")
    
    DoCmd.TransferText acExportDelim, , "エクスポートテーブル", FolderName & "\テスト_" & Format(Now(), "yyyymmdd") & ".csv", True

ExitErrRtn:
    MsgBox "指定されたフォルダにエクスポートしました。"
    Exit Sub
 
ErrRtn:
    MsgBox "エラー： " & Err.description

End Sub