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

-
で実際にフォームでプログラムを使用する際に埋め込んでみたわけです。

まあグタグタですな。ダイアログボックスはNETで調べると案外出てます。色々調べて完成はさせてみましたが、フォーマット固定が多いんでどう使うかは考えものです。
アップローダあればアップして、いろんな人に評価して頂いてソースを綺麗にしたいです。


'#
'#　参照ボタンクリック(CSV取込)
'#
Private Sub Cmd_import_Click()          '参照ボタンクリック時(データインポート)

    Dim j, k As Integer                     '複数strpass選択時のカウンタ
    Dim m, n As Integer                     'テーブル名取得用カウンタ
    Dim strpass As String                   'インポート対象パス
    Dim strVal As Boolean                   '関数結果受け取り
    Dim strFName As String                  'テーブル名取得用、ファイル名入力用
    Dim strpassW As String                   'インポートパス分割ワーク用
    Dim strMsg As String
   
    Dim strSheetName As String              'EXCEL取込時のシート名格納用
   
    'テーブルバックアップ用
    Dim strTableName  As String                       'テーブル名
    Dim db_Dao As DAO.Database
    Dim TableLoop As TableDef
    
    '拡張子判別用
    Dim strEXT As String                    '拡張子格納用
   
    '関数受取
    Dim strRtn As String
   
   
    '//*　ダイアログでファイル選択
    strpass = Dialog.MGetFile("D:\Documents and Settings\a20626\My Documents")               'ダイアログ呼び出し
    'strpassを選択していない場合は何もしない
    If strpass = "" Then
        Exit Sub
    End If
   
    '//*　テーブルバックアップ
        Set db_Dao = CurrentDb
        For Each TableLoop In db_Dao.TableDefs
           strTableName = TableLoop.Name                    'テーブル名取得
       
        '特殊テーブルは除外:テーブルバックアップ
           If Left(strTableName, 2) <> "MS" And Left$(strTableName, 3) <> "~TM" And Left$(strTableName, 4) <> "USys" Then
                  If TableOparate.TableExists(strTableName) = True Then
                        strVal = TableOparate.Tablebkup(strTableName)
                  End If
           End If
         Next TableLoop
   
    j = 0               'カウンタに0をセット
    k = Len(strpass)    '文字長を取得する
   
    'ファイル名の文字数をカウントする
    Do Until k <= 0
       j = InStr(k, strpass, "\")
       If j > 0 Then
            Exit Do
       End If
       k = k - 1
    Loop
   
   
    '//*　ファイルのテーブルへの取込
    'テーブル用ファイル名取得
    '  ①最終文字でなければ分解する
    '　②フルパス文字列から改行コード直前までの文字列を取得(strpassW)
    '　③フルパス文字列の改行コード以降の文字列を取得(strpass)
    '　④ファイル名を取得する
    '　⑤CSVインポート

'砂時計開始
    Application.Screen.MousePointer = 11
   
    Do Until strpass = ""
    
     '選択したファイル名の分解)
       If InStr(strpass, vbCr) <> 0 Then                         '最終文字列を取得できるようにするための条件
         '改行コードの直前までを取り出し
             strpassW = Left$(strpass, InStr(strpass, vbCr) - 1)
         '改行コードの直後から取り出し
             strpass = Mid$(strpass, InStr(strpass, vbLf) + 1)
       Else
             strpassW = strpass
             strpass = ""                                        '最終取込後に初期化してループを抜ける様にする
      
       End If
      
       strFName = FileOparate.FileNameGet(strpassW, 5)   'テーブル名生成用
      
       strMsg = strpassW & Chr(13) & "ファイルを取込みます。" & _
                "取込テーブルは" & strFName & "となります。" & _
                Chr(13) & "よろしければ、OKをクリックして下さい。"
    
       If strFName = "" Then
           Exit Sub
       End If
        
       If MsgBox(strMsg, vbOKCancel) = vbOK Then
             strEXT = FileOparate.FileNameGet(strpassW, 3)               '拡張子取得
             Select Case strEXT
                 Case Is = ".csv", ".txt"
                         strRtn = Csv_op.FromCSV(CONFIGTABLENAME, strFName, strpassW, strEXT)
                
                 Case Is = ".xls"
                        
                          strSheetName = InputBox("取込EXCELのシート名を指定してください。")
                          strRtn = FromExcel(CONFIGTABLENAME, strFName, strpassW, strSheetName)
                
                 Case Else
                        MsgBox "取込めないファイルを選択している可能性があります。" & Chr(13) & _
                               "TXT,CSV,XLSのいずれかのデータを選択してください。"
                                Application.Screen.MousePointer = 0
             End Select
        End If
   
    Loop
       
    '//*　終了
    If strRtn = "True" Then
         Application.Screen.MousePointer = 0
         MsgBox strFName & "をテーブルに取込みました。", vbInformation
        Exit Sub
    Else
         Application.Screen.MousePointer = 0
         MsgBox "処理を中断しました。もう一度やり直してください。", vbCritical
    End If

End Sub

Private Sub b_Sort_Click()
'#
'#　並替ボタンクリック(データ並替)
'#

    Dim strIname As String
    Dim strOname As String
    Dim strRtn As String
   
    strIname = InputBox("取込んだファイルの名前を入力してください。")
    strOname = InputBox("出力するテーブル名を入力してください。")

   
    If strIname <> "" And strOname <> "" Then
        strRtn = DataSort.Sorter(TRASFERTABLENAME, strIname, strOname)
    Else
        MsgBox ("ファイル名を入力してください。")
        Exit Sub
    End If


    If strRtn = "True" Then
        MsgBox ("処理が完了しました。")
    Else
       MsgBox "処理を中断しました。もう一度やり直してください。" & Chr(13) & "取込ファイル名が誤っている可能性が考えられます。", vbCritical
    End If

End Sub

Private Sub Cmd_export_Click()      '保存ボタンクリック(データエクスポート)
'#
'#　保存ボタンクリック(EXCELにエクスポート)
'#

    Dim strac As String
    Dim varFlname As String
    Dim strMsg As String
    Dim strOext As String
    Dim strSheetName As String

    '関数受取
    Dim strRtn As String

    strac = InputBox("出力テーブル名を入力してください。")                '出力テーブルの指定
   
    If strac <> "" Then
        varFlname = oDialog.GetFile("")
        strMsg = strac & " を、ファイルへ出力します。" & _
                 "出力先は" & Chr(13) & varFlname & "です。" & _
                  "よろしければ、OKをクリックして下さい。"
    Else
        MsgBox ("出力テーブル名が入力されていません。")
        Exit Sub
    End If
   
    If varFlname = "" Then
        Exit Sub
    End If
       
        If MsgBox(strMsg, vbOKCancel) = vbOK Then
           '砂時計開始
            Application.Screen.MousePointer = 11
            strOext = FileOparate.FileNameGet(varFlname, 3) '//拡張子取出
            Select Case strOext
           
                Case Is = ".csv", ".txt"
                        strRtn = Csv_op.ToCsv(strac, varFlname, strOext)
                       
                Case Is = ".xls"
                        '出力シートの指定
                        strSheetName = InputBox("出力先のシート名を入力してください。")
                        strRtn = Excel_op.ToExcel(strac, varFlname, strSheetName)
               
                Case Else
                        MsgBox "出力できないファイルを選択している可能性があります。" & Chr(13) & _
                               "TXT,CSV,XLSのいずれかのデータを選択してください。"
                                Application.Screen.MousePointer = 0
                        Exit Sub
            End Select
         End If

    If strRtn = "True" Then
        Application.Screen.MousePointer = 0
        '//*　バックアップテーブル削除
        Call TableOparate.TableDel
        MsgBox strac & "データを出力しました。", vbInformation
        Exit Sub
    Else
        Application.Screen.MousePointer = 0
        MsgBox "処理を中断しました。もう一度やり直してください。" & Chr(13) & "出力したいテーブル名が誤っている可能性が考えられます。", vbCritical
    End If
       
End Sub

コメント

コメントを投稿

このブログの人気の投稿

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 コントロールの初期化とスクリ...
続きを読む