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

-
 とりあえずCSV制御部分の備忘録
テーブルで入力するファイルを定義し、出力したいテーブルと出力項目を
テーブルで設定します。
 テーブルは別途用意する必要があります。（笑）


Function FromCSV(strTableName As String, strImportTableName As String, strCsvFileName As String, strMode As String) As String
On Error GoTo ERROR_SUB
'====================================================================
' テーブルからCSVの定義を取得してインポートする。
' 可変CSV(カラム追加の可能性のあるテーブル)インポート関数
' 2010.02.02 Created By M.Nishimura
'＊使い方
'  str_rtn = FromCSV(定義テーブル名,取込テーブル名,CSVファイル名)
'＊戻り値
'　True：処理正常終了
'　False：処理失敗
'
'====================================================================
    Const COLUMCNT = 256                            'カラム数
   
    Dim db_Dao(1) As DAO.Database
    Dim Rst_Dao(1) As DAO.Recordset
    Dim Qdf_Dao As DAO.QueryDef
    Dim strTname As String                     'テーブル名
   
    Dim dbsCurrent As DAO.Database
    Dim strSQL As String
    Dim tdfNew As DAO.TableDef
    Dim tdffld(COLUMCNT) As DAO.Field

    Dim strClum(COLUMCNT) As String
    Dim strFieldName(COLUMCNT) As String       'フィールド名(カラム数分の配列)
    Dim strFieldSize(COLUMCNT) As String       'フィールドサイズ(カラム数分の配列)
    Dim intFieldSize(COLUMCNT) As Integer      'フィールドサイズ(カラム数分の配列)
    Dim striTname As String                    'インポートテーブル名
    Dim balRetTableExists As Boolean
   
    Dim i As Integer                'レコードカウント用
    Dim j As Integer                'カラム数
    Dim k As Integer                'カラム比較用
    Dim F As Integer                'CSV先頭行除外用
   
    Const CSVTOP = 0
    Dim strC As String              '区切文字
    Dim Swork As String
   
    'テキストの場合はタブ区切り(条件分岐させれば区切文字可変可能)
    strC = vbTab

    i = 0
    j = 0
    k = 0
    strTname = strTableName
    striTname = strImportTableName
    FromCSV = "False"
    strFlName = strCsvFileName
    
'ワークテーブルの存在を確認した後,ワークテーブルが存在すればワークテーブル削除
    balRetTableExists = TableOparate.TableExists(striTname)
    If balRetTableExists = True Then
        DoCmd.DeleteObject acTable, striTname
    End If
    
'呼出しテーブル定義
    strSQL = ""
    strSQL = strSQL & " SELECT " & strTname & ".*"
    strSQL = strSQL & " FROM "
    strSQL = strSQL & strTname & ";"
    strSQL = 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(striTname)

    i = Rst_Dao(0).RecordCount
   
'レコード数取得
    If i <> 0 Then
        Rst_Dao(0).MoveLast
        j = Rst_Dao(0).RecordCount
        Rst_Dao(0).MoveFirst
    End If
       
    k = 0
'//**　テーブル作成(テーブルを新規作成<カラムは可変(全てテキスト型)>)　**
    Do Until k = j
        strFieldName(k) = Nz(Rst_Dao(0).Fields(2))  'フィールド名
        strFieldSize(k) = Nz(Rst_Dao(0).Fields(3))  'フィールドサイズ
        intFieldSize(k) = CInt(strFieldSize(k))
       
        Set tdffld(k) = tdfNew.CreateField(strFieldName(k), dbText, intFieldSize(k))
        tdffld(k).AllowZeroLength = True '空文字列の許可
        tdfNew.Fields.Append tdffld(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(striTname, dbOpenTable)

'//**　CSVデータ取込　****
'//**　ファイル拡張子において区分けしている。CSV以外はsplitで処理
    Open strFlName For Input As #1
    F = 0
    Select Case strMode
        '//* CSV(カンマ区切)の処理
        Case Is = ".csv"
            Do Until EOF(1)
                k = 0
                Do Until k = j
                    Input #1, strClum(k)
                    k = k + 1
                Loop
                '先頭1行は表題なのでテーブルに書き込まない
                If F <> CSVTOP Then
                    k = 0
                    Rst_Dao(1).AddNew
                    Do Until k = j
                        Rst_Dao(1).Fields(k) = Nz(strClum(k))
                        k = k + 1
                    Loop
                    Rst_Dao(1).Update
                End If
                F = F + 1
            Loop
        '//* txtファイルの処理
        Case Is = ".txt"
            Do Until EOF(1)
                k = 0
                Line Input #1, Swork
                If F <> CSVTOP Then
                    Rst_Dao(1).AddNew
                    Do Until k = j
                    'タブ区切でないTXTだとエラーとなるため処理を中止する。
                        If Swork <> "" Then
                            strClum(k) = Split(Swork, strC)(k)
                            Rst_Dao(1).Fields(k) = Nz(strClum(k))
                            k = k + 1
                        Else
                            GoTo ERROR_SUB
                        End If
                    Loop
                    Rst_Dao(1).Update
                End If
                F = F + 1
            Loop
        Case Else
            GoTo ERROR_SUB
    End Select
   
    Close #1

'* DBのクローズ
    Rst_Dao(0).Close
    db_Dao(0).Close
    Rst_Dao(1).Close
    db_Dao(1).Close

    FromCSV = "True"
    Exit Function


'//*　エラー処理　*//
ERROR_SUB:

    'エラー処理
'    Call MsgBox(CStr(Err.Number) & "," & Err.Description)  '*デバッグ用
   
    MsgBox "TXTファイルはタブ区切、CSVファイルはカンマ区切です。" & Chr(13) & _
           "ファイル形式に誤りがある可能性があります。取込ファイルを修正してください。" & Chr(13) & _
           "ファイルを修正してもエラーが続く場合は、定義テーブルを確認してください。" & Chr(13) & _
           "それでもエラーが解消されない場合はシステム管理者に連絡してください。"
          
    Close #1
    FromCSV = "False"
    Exit Function

End Function
Function ToCsv(StrDataName As String, StrFileName As Variant, strMode As String) As String
'====================================================================
' CSVデータエクスポート
' 2010.05.18 Created By M.Nishimura
'＊使い方
'  str_rtn = ToCSV(出力元テーブル名,出力先CSVファイル)
'＊戻り値
'　True：処理正常終了
'　False：処理失敗
'
'====================================================================
On Error GoTo err_a
   
    Dim db_Dao As DAO.Database
    Dim Rst_Dao As DAO.Recordset
   
    Dim strMsg As String
    Dim intmsg As Integer
    Dim varinput1, varinput2 As Variant
   
   
    Dim outi As Integer            '出力テーブルフィールドカウント用
    Dim lasti As Integer           '最終フィールド数
    Const CORUM = 0                'データ部フィールドカウンタの初期値
    Dim strF As String             '「"」表現用
    Dim strC As String             '区切記号用
   
    Dim strOutput As String        'CSV出力用文字列
    Dim balRetTableExists As Boolean
   
   
   
    strMsg = "CSVファイルへデータを出力しますか ？"
    intmsg = MsgBox(strMsg, 17, "管理者")

    ToCsv = "False"

    '出力用テーブルチェック
    balRetTableExists = TableOparate.TableExists(StrDataName)
    If balRetTableExists = False Then
        Exit Function
    End If

    If intmsg = 1 Then
        Set db_Dao = CurrentDb
        '出力元のテーブルまたはクエリ名です。
        varinput2 = StrDataName
       
        If varinput2 <> "" Then
            Set Rst_Dao = db_Dao.OpenRecordset(varinput2)
        Else
            Exit Function
        End If
        'ファイル名指定
        varinput1 = StrFileName
        If IsNull(varinput1) Then End
               
       'CSVファイルの場合は「"",""」形式、テキストの場合はタブ区切り
       '*****　CSVファイルを「,」のみ形式にしたいときはstrFを""に書替
       If strMode = ".csv" Then
          strF = Chr(34)
          strC = Chr(44)
       Else
          strF = ""
          strC = vbTab
       End If
               
       lasti = Rst_Dao.Fields.Count
       Rst_Dao.MoveFirst
       
       
'// CSVデータ出力
        Open varinput1 For Append As #1  '出力ファイルを開く
       
        '*　タイトル出力
        outi = CORUM
        Do Until outi = lasti
           If outi = lasti - 1 Then
                strOutput = strOutput & strF & Rst_Dao.Fields(outi).Name & strF                          '最終レコードはカンマなし
           Else
                strOutput = strOutput & strF & Rst_Dao.Fields(outi).Name & strF & strC
           End If
           outi = outi + 1
        Loop
        Print #1, strOutput
       
        '*　データ本体出力
        Do Until Rst_Dao.EOF
                outi = CORUM                  'フィールドを1列目にセット
                strOutput = ""
                Do Until outi = lasti         'フィールド出力
                   If outi = lasti - 1 Then
                        strOutput = strOutput & strF & Rst_Dao.Fields(outi).Value & strF
                   Else
                        strOutput = strOutput & strF & Rst_Dao.Fields(outi).Value & strF & strC
                   End If
                   outi = outi + 1
                Loop
                Print #1, strOutput
                Rst_Dao.MoveNext
        Loop
       
        Rst_Dao.Close
        Close #1 '出力ファイルを閉じる
          
        Set Rst_Dao = Nothing
        Set db_Dao = Nothing
        ToCsv = "True"
    Else
        MsgBox "処理を中止しました", 1, "管理者"
        Set Rst_Dao = Nothing
        Set db_Dao = Nothing
    End If
   
    Exit Function
   
err_a:

    MsgBox "Error番号：" & Err.Number & vbNewLine & _
            "Error内容：" & Err.Description, 16, "管理者"
               
    Close #1
    ToCsv = "False"

End Function

コメント

コメントを投稿

このブログの人気の投稿

GASでGoogleDriveのサブフォルダとファイル一覧を出力する

-
 タイトルのまんまです。 以前、EXCELで似たようなこと をしていたのでGASではどうするのかなぁと思ってやってみました。まぁほとんど丸パクリです。とりあえず、また使うかもしれないので自分用にメモです。しかしGASでGoogleDriveのファイル一覧嘗め回そうとすると3分かかってしまう。数が多いと6分制限に引っかかるのでこれでは使えない。せいぜい100ファイルとか数が少ないところで使う分にはいいけどダイナミックな場合は何回かに分割してやらないと少し厳しいかもしれない。 ◆GAS //設定値取得 const SHEET_URL = SpreadsheetApp.getActiveSpreadsheet().getUrl(); const ss = SpreadsheetApp.openByUrl(SHEET_URL); const SETTING_SHEET = ss.getSheetByName('設定') const TARGET_FOLDER_ID = SETTING_SHEET.getRange('B2').getValue(); const SAVE_FOLDER_ID = SETTING_SHEET.getRange('B3').getValue(); const SAVE_FILE_NAME = SETTING_SHEET.getRange('B4').getValue(); const SAVE_SHEET_NAME = SETTING_SHEET.getRange('B5').getValue(); function writeSheet(values, labels, sheetUrl, sheetname, width) { /* スプレッドシートに書き出し */ try { if (values.length > 0) { // シートを追加する let spreadSheet = SpreadsheetApp.openByUrl(sheetUrl); let sheet = set_sheet(sheetUrl,sheetname); // 1行目だけヘッダ追加 let he...
続きを読む

マクロ経済学(IS-LM分析)

-
イメージ
危うく3日坊主になりそうでした。とりあえず今日は 「IS-LM分析」 です。 テキストでは 簡便4象限法 とかいうのの説明が多いです。なのでさっぱり わけわからん状態ですが、それなりに頑張ってみます。 1: IS曲線 の導出 財市場の均衡を表す。Iは投資を表し、Sは貯蓄を表す。 ・IS曲線導出の材料 I→利子率の関数、S→所得の関数で「I=S」で財市場を表す。 ・ 投資関数 利子率の減少関数、I (投資関数)=I(r)　※rは利子率 ・政府活動の導入 裁量的な拡張的な財政政策はIS曲線をシフトさせる。 IS曲線の右シフト=政府支出の増大や減税等の有効需要を増加させる要因による 2: LM曲線 の導出 利子率の低下が国民所得の増大につながる因果関係を明らかにする目的 ・LM曲線導出の材料 貨幣需要(MD)=L、L=取引的動機+予備的動機(L1)+投機的動機(L2) MD=L1+L2 貨幣供給(Ms)=名目貨幣供給/物価(P) ・LM曲線のシフト 金融緩和策・物価下落：実質貨幣供給(MS)が増大→右(下)へシフト 金融引締策・物価上昇：実質貨幣供給(MS)が減少→左(上)へシフト 独立投資拡大→IS曲線が右にシフト 利子率がr1→r2に下落する。 IS曲線、LM曲線の均衡点がE→Fに移動する。 国民所得がY1→Yfとなって増大する。 3:特殊なLM曲線 ・ 流動性の罠 のLM曲線 金融政策は無効→LM曲線をシフトさせても均衡点Eは変わらない IS曲線を右にシフトさせる拡張的な財政政策を実施すると均衡点が E→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　 ・ 投資の利子率に対する弾力性ゼロ 金融政策は無効→LM曲線を右にシフトさせても国民所得が増えない。 流動性の罠と同じくIS曲線を右にシフトさせる拡張的な財政政策を実施すると 均衡点がE→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　　　　 4: クラウディング・アウト 政府が市場に介入して公共投資を行うと民間の投資が締出しを受ける ・古典派による財政政策の無効論 政府支出を拡大すると利子率が上昇してしまい。投資が減少する。 政府の支出がクラウディングアウトを引き起こして支...
続きを読む

IEのセキュリティ設定をいじくるバッチ

-
まぁかなり頻出ですがIEでアプリ用に設定しないといけなくて クリックOnlyで処理したかったので色々と調べてみて作ってみた。 ローカルイントラネットの設定いじくるのとActiveX関連をいじくるのと 互換表示設定をいじくっています。 というよりそういう設定しないと動かないアプリの組み方辞めてください。 頼むから・・・。 挙動が微妙に他と違うのでIEとかEdgeには苦しめられます。 @echo off set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap" reg add %REGROOT% /f /v "AutoDetect" /t REG_DWORD /d "0" reg add %REGROOT% /f /v "IntranetName" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "ProxyBypass" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "UNCAsIntranet" /t REG_DWORD /d "1" rem IEのローカルイントラネット設定(*ドメイン指定) set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Ranges\Range1" set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains\対象ドメイン" reg add %REGROOT% /f /v "*" /t REG_DWORD /d "1" rem スクリプトを実行しても安全だとマークされていない activex コントロールの初期化とスクリ...
続きを読む