2013年3月25日
今回はVBAではなく、VB6ネタです。 いまさらVB6か?といわれそうですが… 某企業様で、VB6で作成した生産管理システムがあり、この前国会で決まった「消費税率アップ」に対応したい、との相談がありました。
このシステム全体はVB6で構築されており、データはAccessデータベースに保存されています。消費税率はプログラムに埋め込んであり、今後段階的にアップされることになっている消費税率をその都度対応するには…。ということで支援することになりそうです。
そこで事前検討した結果を少しアレンジして紹介します。
方針としては、
1.年月日により適用する消費税率が段階的に変わっていくので、システム外部に消費税率と適用開始日のリストを用意しておく
2.システム内の計算式の該当部分を、消費税率を外部のリストから読込んで返す「関数」に置き換える
3.「外部のリスト」は、mdb、xls、csvのいずれでも対応できるようにする
4.以上を踏まえ、「関数」をDLLとして開発する
としました。
■消費税率と適用開始日のリスト
以下のようなデータファイルを作成しました。
mdbの場合
ファイル名 | ctr.mdv | |
テーブル名 | m_ctr | |
フィールド名 | ctr | applydate |
内容 | 消費税率 | 適用開始日 |
データ型 |
単精度 浮動小数点型 |
テキスト型 |
xlsの場合
ファイル名 | ctr.xls | |
シート名 | m_ctr | |
項目名 | ctr | applydate |
内容 | 消費税率 | 適用開始日 |
データ | 実数 | 整数 |
csvの場合
ファイル名 | ctr.csv | |
項目名行 | ctr | applydate |
内容 | 消費税率 | 適用開始日 |
データ | 半角のカンマ「,」で区切る | |
実数 | 整数 |
そんなに難しいものではないので全コードの解説はしませんが、ポイントだけ…
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
DLLを呼び出す側の例は以下のようになります。
Private Sub Command4_Click()
Dim targetdate As Variant
targetdate = Format(txtDate.Text, "yyyy/mm/dd")
MsgBox targetdate & vbCrLf _
& getCTRsub(targetdate) 'ボタンを押したとき、フォーム上のデータをDLLに渡す
End Sub
'このファイルと同じフォルダに
'ConsumptionTaxRate.dll
'ctr.mdb
'が配置されているとしています
'regsvr32 "[保存パス]¥ConsumptionTaxRate.dll"
'でレジストリに登録が必要
'DLLを呼び出すプロシージャ
Public Function getCTRsub(targetdate As Variant) As Single
Dim obj As Object
Dim DBName As String
Dim clsname As String
'データファイルへのパスをセット
DBName = Form1.Combo1.Text
'呼び出すクラスをセット
Select Case DBName
Case "ctr.mdb": clsname = "mdbCTR" '…mdbのとき
Case "ctr.xls": clsname = "xlsCTR" ' …xlsのとき
Case "ctr.csv": clsname = "csvCTR" ' …csvのとき
End Select
'該当のクラスを呼び出す
Set obj = CreateObject("ConsumptionTaxRate." & clsname)
'データファイルのパスと調べたい年月日を渡す
getCTRsub = obj.getCTR(App.Path & DBName, targetdate)
Set obj = Nothing
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の場合と同じです。