2013年3月25日

今回はVBAではなく、VB6ネタです。
いまさらVB6か?といわれそうですが…
某企業様で、VB6で作成した生産管理システムがあり、この前国会で決まった「消費税率アップ」に対応したい、との相談がありました。
このシステム全体はVB6で構築されており、データはAccessデータベースに保存されています。消費税率はプログラムに埋め込んであり、今後段階的にアップされることになっている消費税率をその都度対応するには…。ということで支援することになりそうです。

そこで事前検討した結果を少しアレンジして紹介します。
 方針としては、
1.年月日により適用する消費税率が段階的に変わっていくので、システム外部に消費税率と適用開始日のリストを用意しておく
2.システム内の計算式の該当部分を、消費税率を外部のリストから読込んで返す「関数」に置き換える
3.「外部のリスト」は、mdb、xls、csvのいずれでも対応できるようにする
4.以上を踏まえ、「関数」をDLLとして開発する
としました。


■消費税率と適用開始日のリスト
以下のようなデータファイルを作成しました。

そんなに難しいものではないので全コードの解説はしませんが、ポイントだけ…
1.　ADODBの仕組みを使いデータファイルにアクセスします
2.　CreateObjectでADODBに接続することで、VB6のプロジェクトに参照設定しないでもいいようにします
3.　クエリは、データをいったん「適用開始日の降順」に並べ替えて取得したあと、指定年月日以前のレコードを取出し、先頭のひとつを返すものになっています。
単純に、指定年月日以前のレコードを取出し、「適用開始日の降順」に並べ替えて、先頭のひとつを返す、でもいいんですけどね。
こんなクエリの書き方もあるということで何かのときの参考にしてください。 
4.　実装するときには、渡された年月日が正しい形式になっているかどうか、データファイルが存在するかどうかなど、エラーチェックを追加してくださいね…

mdbから読込む場合のソースプログラム（クラスとして構築します）は下記のようになります。

Const cnsProvider = "Microsoft.Jet.OLEDB.4.0"

【mdbCTR.cls　の内容】

Const TableName As String = "m_ctr"

Public Function getCTR(dbpath As String, ByVal targetdate As Variant) As Single
    'カレントフォルダの mdb に接続
    Dim strsql  As String
'    Dim cnn As New ADODB.Connection
    Dim cnn As Object
    Dim rs As Object
    
    Set cnn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    getCTR = 0 '見つからないときは0を返す
    
    targetdate = Format(targetdate, "yyyymmdd")
    
    On Error GoTo ErrTrap

    'SQLクエリ
    strsql = ""
    strsql = strsql & " select * from "
    strsql = strsql & "( "
    strsql = strsql & "select * from " & TableName & " "
    strsql = strsql & " Order By applydate Desc "
    strsql = strsql & ") "
    strsql = strsql & " where applydate<='" & targetdate & "' "
                    '文字列に設定してあるので「'」が必要
    '接続
    With cnn
        .Provider = cnsProvider
        .Open dbpath
    End With
   
    'カーソルオープン(読み取り専用)
    With rs      'adOpenForwardOnly, adLockReadOnly, adCmdText
        .Open strsql, cnn, 0, 1, 1
    End With
    If Not rs.BOF Then
        rs.MoveFirst
        getCTR = rs.Fields("ctr").Value   '先頭のひとつを返す
    End If
    rs.Close
    Set rs = Nothing
    cnn.Close
    Set cnn = Nothing
ErrTrap:
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbCritical, "エラー発生"
    End If
    
    On Error GoTo 0
    
End Function

xlsやcsvのときも同様にできますが、若干違うところがあります。
◆xlsの場合
Const cnsExtProprtys = "Extended Properties"
Const cnsExcel = "Excel 8.0" ';HDR=YES;" ' .xls -2003　一行目はフィールド列
Const SheetName As String = "m_ctr"
   strsql = strsql & " where applydate<=" & targetdate & " "
   'Excelが自動的に型判定し、テク用年月日は数値と判定それるので、「'」をつけません
    '接続
    With cnn
        .Provider = cnsProvider
        .Properties(cnsExtProprtys) = cnsExcel
        .Open dbpath
    End With
他はmdbの場合と同じです。

◆csvの場合
Const cnsExtProprtys = "Extended Properties"
Const cnsCSV = "text;HDR=Yes;FMT=Delimited;" '1行目はフィールド名、「,」区切り
'Const CSVName As String = "ctr.csv"
 csv_folder = Left(dbpath, pos)          'データファイルのフォルダ名　を取出す
 csv_file = Right(dbpath, Len(dbpath) - pos)     'データファイル名　を取出す
    strsql = ""
    strsql = strsql & " select * from "
    strsql = strsql & "( "
    strsql = strsql & "select * from " & csv_file & " "
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　'…データファイル名を渡す
    strsql = strsql & " Order By applydate Desc "
    strsql = strsql & ") "
    strsql = strsql & " where applydate<=" & targetdate & " "
                    '自動的に型判定され数値になるので「'」はなし
    '接続
    With cnn
        .Provider = cnsProvider
        .Properties(cnsExtProprtys) = cnsCSV
        .Open csv_folder                  '…データファイルのフォルダ名　を渡す
    End With
他はmdbの場合と同じです。