ACCESS でCSV出力ツール作ってみた（その2）

 データ並べ替え部分です。ここがこのACCESSのキモかも
しれないです。まあ頭は使いました。（笑）

Function Sorter(strConfTableName As String, strInTableName As String, strOutTableName As String) As String
'=========================================================================
'関数名：Sorter (ファイル変換処理用)
'
'機能　：入力テーブルを受け取って定義テーブルに設定されたとおりに並替して
'　　　　指定されたテーブルに出力する。
'
'使い方：strRet = SampleTemplate1("定義テーブル名","入力テーブル名","出力テーブル名")
'
'戻り値： "True"　正常終了
'         "False" 異常終了(エラーNOを持たせる場合はそれぞれで個別定義必要)
'=========================================================================

    Const MAXBYTE = 255         '出力テーブル作成時のフィールドデータのサイズ
    Const COLUMCNT = 256        'カラム数

   
'//* 変数定義
    Dim strConf As String       '定義テーブル
    Dim strIFile As String      '入力テーブル
    Dim strOFile As String      '出力先テーブル
   
    Dim strClum(COLUMCNT) As String
    Dim strFieldName(COLUMCNT) As String       'フィールド名(カラム数分の配列)
    Dim balRetTableExists As Boolean
   
    Dim db_Dao(2) As DAO.Database
    Dim Rst_Dao(2) As DAO.Recordset
    Dim Qdf_Dao As DAO.QueryDef
   
    Dim dbsCurrent As DAO.Database
    Dim strSQL As String
    Dim tdfNew As DAO.TableDef
    Dim tdffld(COLUMCNT) As DAO.Field
   
    Dim intFieldNO(COLUMCNT) As Integer '入力テーブルのカラム位置
    Dim intFCNT As Integer              '上記テーブル内の値をセット
    Dim intLASTDATA   As Integer        '保存されているデータのレコード数
    Dim intFieldLast  As Integer        'フィールド数の最大値
   
'//* 引数のエラーチェック
    Sorter = "False"                    '関数初期化
   
    If strConfTableName <> "" And strInTableName <> "" And strOutTableName <> "" Then
        strConf = strConfTableName
        strIFile = strInTableName
        strOFile = strOutTableName
    Else
        Exit Function
    End If
   
    '入力テーブル存在チェック
    balRetTableExists = TableOparate.TableExists(strIFile)
    If balRetTableExists = False Then
        Exit Function
    End If
   
    '定義テーブル存在チェック
    balRetTableExists = TableOparate.TableExists(strConf)
    If balRetTableExists = False Then
        Exit Function
    End If
   

'//* ワークテーブルの存在を確認した後,ワークテーブルが存在すればワークテーブル削除
    balRetTableExists = TableOparate.TableExists(strOFile)
    If balRetTableExists = True Then
        DoCmd.DeleteObject acTable, strOFile
    End If

'//* 定義テーブル読込
    strSQL = ""
    strSQL = strSQL & " SELECT " & strConf & ".*"
    strSQL = strSQL & " FROM "
    strSQL = strSQL & strConf
    strSQL = strSQL & " WHERE ((" & strConf & ".f_OutputFlg) = '1')"
    strSQL = strSQL & " ORDER BY " & strConf & ".f_OutputColum;"
    strSQL = strSQL & ""

'    'デバッグ用
'    Debug.Print strSQL
   
    Set db_Dao(0) = CurrentDb
    Set Qdf_Dao = db_Dao(0).CreateQueryDef("", strSQL)
    Set Rst_Dao(0) = Qdf_Dao.OpenRecordset()
   
   
'//* 出力テーブル作成
    Set dbsCurrent = CurrentDb
    Set tdfNew = dbsCurrent.CreateTableDef(strOFile)
    i = Rst_Dao(0).RecordCount
   
    If i = 0 Then        'レコード件数が0の場合は処理できない。
         Exit Function
    Else
        'フィールド数を取得する
        Rst_Dao(0).MoveLast
        intFieldLast = Rst_Dao(0).RecordCount
        Rst_Dao(0).MoveFirst
    End If
               
    Do Until k = intFieldLast
        strFieldName(k) = Nz(Rst_Dao(0).Fields(2))                              'フィールド名
        Set tdffld(k) = tdfNew.CreateField(strFieldName(k), dbText, MAXBYTE)
        tdffld(k).AllowZeroLength = True                                        '空文字列の許可
        tdfNew.Fields.Append tdffld(k)
       
        intFieldNO(k) = Nz(Rst_Dao(0).Fields(0).Value)  '入力テーブルカラムの値をセット
       
'    Debug.Print k & "テーブル作成時格納" & intFieldNO(k)
   
        Rst_Dao(0).MoveNext
        k = k + 1
    Loop

    tdfNew.Fields.Refresh
    dbsCurrent.TableDefs.Append tdfNew
    dbsCurrent.TableDefs.Refresh
    dbsCurrent.Close

    Set db_Dao(1) = CurrentDb
    Set Rst_Dao(1) = db_Dao(1).OpenRecordset(strOFile, dbOpenTable)

'出力データ生成
'// 入力テーブル読込
    Set db_Dao(2) = CurrentDb
    Set Rst_Dao(2) = db_Dao(0).OpenRecordset(strIFile)
    i = Rst_Dao(2).RecordCount

    If i = 0 Then
         Exit Function
    Else
        Rst_Dao(2).MoveLast
        intLASTDATA = Rst_Dao(2).RecordCount
        Rst_Dao(2).MoveFirst
    End If
   
    i = 0
    Do Until i = intLASTDATA
        k = 0
       
        Rst_Dao(1).AddNew
        Do Until k = intFieldLast
            intFCount = intFieldNO(k)
            Rst_Dao(1).Fields(k).Value = Nz(Rst_Dao(2).Fields(intFCount).Value)
            k = k + 1
            intFCount = intFCount + 1
        Loop
        Rst_Dao(1).Update
       
        Rst_Dao(2).MoveNext
        i = i + 1
    Loop

'* DBのクローズ
    For F = 0 To 3
        Set Rst_Dao(0) = Nothing
        Set db_Dao(0) = Nothing
    Next F
    Sorter = "True"
    Exit Function

ERROR_SUB:
    For F = 0 To 3
        Set Rst_Dao(0) = Nothing
        Set db_Dao(0) = Nothing
    Next F
    Sorter = "False"

End Function