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