パソコン情報

【Access】フォームのレコードソースをエクスポートする方法

以前に、非連結のテキストボックスやコンボボックスから抽出したレコードをフォームのレコードソースにする方法を記事にしたことがありました。

https://pctips.jp/pc-soft/access-textbox-judg-extract/

 

今回は、

ココがポイント

その抽出したレコードソースを、CSVファイルなどにエクスポートする方法

をやって見たいと思います。

 

 

方法は一つじゃない!?

方法はいくつかあるのかと思いながらもネットで同じような事例が無いかと調べましたが、中々出てきません。

いちばん簡単なのは、非連結ボックスや非連結のコンボボックスを指定して抽出したクエリをそのままエクスポートすれば事は足りると思います。

https://pctips.jp/pc-soft/access-export-selectfolder/

 

ただ、今回は、せっかくフォームのレコードソースとしてVBAにて抽出したので、そのレコードソースをエクスポートできないものか?と考えた訳です。

 

ダミーのクエリを使ってエクスポート

ネットを探してみると、なんでダミーのクエリをつかってエクスポートできるのかわかりませんが、下記の様なコードを見つけました。

Dim qd As DAO.QueryDef

Set qd = CurrentDb.QueryDefs("Q_Dummy")
qd.SQL = "SELECT * FROM (フォームのレコードソース) WHERE " & Me.Filter

DoCmd.TransferText acExportDelim, , "Q_Dummy", "C:\Test\Test.csv", True

 

ほぼ諦めかけていたので、DAOを嫌っていた自分ですが、今回はDAOを使ってほしい機能が実現できたので良しとしました。

 

複雑なSQL抽出データをエクスポート

Private Sub csv_xport_Click()
    Dim hantei As Integer
    Dim naiyou As String
    
    Dim dbs As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim flg As Boolean

     Dim strSql As String
     Dim strPath As String
     Dim FolderName As String
   
        FolderName = getFolderName("")   '引数に初期値のフォルダーパスを設定、""にするとドキュメントフォルダー
           
        If FolderName = "" Then
            MsgBox "キャンセルされました。"
        Else
        
        
  ' 条件が設定されてない時は抽出しない
If Nz(Me.search_mado, "") = "" And Nz(Me.delivery_mado, "") = "" And Nz(Me.trader_search, "") = "" And Nz(Me.pu_date_start, "") = "" And Nz(Me.pu_date_end, "") = "" And Nz(Me.delivery_date_start, "") = "" And Nz(Me.delivery_date_end, "") = "" Then
    Call 解除ボタン_Click
    Exit Sub
End If


haitei = 0

    If Nz(Me.pu_date_start, "") <> "" And Nz(Me.pu_date_end, "") <> "" Then
        hantei = hantei + 1

    ElseIf Nz(Me.pu_date_start, "") <> "" Then
        If Nz(Me.pu_date_end, "") = "" Then
            MsgBox "集荷日終了が入力されていません"
        Exit Sub
        End If
        
    ElseIf Nz(Me.pu_date_end, "") <> "" Then
        If Nz(Me.pu_date_start, "") = "" Then
            MsgBox "集荷日開始が入力されていません"
        Exit Sub
        End If
    End If
    
    
    If Nz(Me.delivery_date_start, "") <> "" And Nz(Me.delivery_date_end, "") <> "" Then
        hantei = hantei + 10
        
    ElseIf Nz(Me.delivery_date_start, "") <> "" Then
        If Nz(Me.delivery_date_end, "") = "" Then
            MsgBox "配達日終了が入力されていません"
        Exit Sub
        End If
        
    ElseIf Nz(Me.delivery_date_end, "") <> "" Then
        If Nz(Me.delivery_date_start, "") = "" Then
            MsgBox "配達日開始が入力されていません"
        Exit Sub
        End If
    End If
    
    If Nz(Me.search_mado, "") <> "" Then    ' 出荷人
    hantei = hantei + 100
    End If

    If Nz(Me.trader_search, "") <> "" Then  ' 業者
    hantei = hantei + 1000
    End If
    
    If Nz(Me.delivery_mado, "") <> "" Then  ' 配達先
    hantei = hantei + 10000
    End If
    
    naiyou = "(trader1 ='" & Me!trader_search & "'or trader2 = '" & Me!trader_search & "'or trader3 = '" & Me!trader_search & "'or trader4 = '" & Me!trader_search & "'or trader5 = '" & Me!trader_search & "')"

On Error GoTo Err_Handler
            
            If hantei = 100 Then    ' 出荷人
                        strSql = "SELECT * FROM orderdata_sorting WHERE shipper ='" & Me!search_mado & "'"
                        
            ElseIf hantei = 101 Then    ' 出荷人+集荷日
                        strSql = "SELECT * FROM orderdata_sorting WHERE shipper ='" & Me!search_mado & "' And pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#"
            
            ElseIf hantei = 111 Then    ' 出荷人+集荷日+配達日
                        strSql = "SELECT * FROM orderdata_sorting WHERE shipper ='" & Me!search_mado & "' And pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & "And delivery_date Between #" & Me!delivery_date_start & "# AND #" & Me!delivery_date_end & "#"
           
            ElseIf hantei = 10101 Then   ' 出荷人+配達先+集荷日
                        strSql = "SELECT * FROM orderdata_sorting WHERE shipper ='" & Me!search_mado & "'And delivery_name = '" & Me!delivery_mado & "' And pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#"
            
            ElseIf hantei = 11 Then   ' 集荷日+配達日
                        strSql = "SELECT * FROM orderdata_sorting WHERE pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & "And delivery_date Between #" & Me!delivery_date_start & "# AND #" & Me!delivery_date_end & "#"

            ElseIf hantei = 1000 Then   ' 業者
                        strSql = "SELECT * FROM orderdata_sorting WHERE " & naiyou
            
            ElseIf hantei = 11000 Then   ' 業者+配達先
                        strSql = "SELECT * FROM orderdata_sorting WHERE delivery_name = '" & Me!delivery_mado & "' and  " & naiyou
                        
            ElseIf hantei = 11001 Then   ' 業者+配達先+集荷日
                        strSql = "SELECT * FROM orderdata_sorting WHERE delivery_name = '" & Me!delivery_mado & "' and pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & " and  " & naiyou
                        
            ElseIf hantei = 1001 Then   ' 業者+集荷日
                        strSql = "SELECT * FROM orderdata_sorting WHERE pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & " and  " & naiyou

            ElseIf hantei = 1101 Then   ' 出荷人+業者+集荷日
                        strSql = "SELECT * FROM orderdata_sorting WHERE  shipper ='" & Me!search_mado & "' And pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#" & " and  " & naiyou
                        
            ElseIf hantei = 1 Then    ' 集荷日
                        strSql = "SELECT * FROM orderdata_sorting WHERE pu_date Between #" & Me!pu_date_start & "# AND #" & Me!pu_date_end & "#"
                        
            ElseIf hantei = 10 Then   ' 配達日
                        strSql = "SELECT * FROM orderdata_sorting WHERE delivery_date Between #" & Me!delivery_date_start & "# AND #" & Me!delivery_date_end & "#"


'                                                    Debug.Print .Source

            Else
            
             MsgBox "設定外の抽出項目です。設定し直して再抽出してください。"
             Exit Sub
            
            End If
            
                 'エクスポート処理

            flg = False
            Set dbs = CurrentDb
            'クエリ有無
            For Each qdf In dbs.QueryDefs
                If qdf.Name = "Q_Dummy" Then
                    flg = True
                    Exit For
                End If
            Next
            '存在する場合クエリ削除
            If flg = True Then
                dbs.QueryDefs.Delete "Q_Dummy"
                flg = False
            End If
            If flg = False Then
                Set qdf = dbs.CreateQueryDef("Q_Dummy", strSql)
                DoCmd.TransferText acExportDelim, , "Q_Dummy", FolderName & "\抽出CSV_" & Format(Now(), "yyyymmdd") & ".csv", True
               
                dbs.Close 'dbsをクローズ
                Set dbs = Nothing 'dbsを開放
                Set qdf = Nothing 'qdfを開放
                
                                       MsgBox "エクスポート完了しました。"
            End If
        End If
        
ExitErr_Handler:
        Exit Sub

Err_Handler:
        MsgBox "エラー: " & Err.description

End Sub

 

スゲー複雑そうに見えますが、

ココに注意

条件によって抽出したSQLデータをエクスポートしているだけです

結局は、フォームのレコードソースに設定したVBAコードを実行して、今回見つけたエクスポートコードを追加しただけです。