今回は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.xls | |
| 項目名 | ctr | applydate |
| 内容 | 消費税率 | 適用開始日 |
| データ | 実数 | 整数 |
svの場合
| ファイル名 | ctr.csv | |
| 項目名行 | ctr | applydate |
| 内容 | 消費税率 | 適用開始日 |
| データ | 実数 | 整数 |
そんなに難しいものではないので全コードの解説はしませんが、ポイントだけ…
1. ADODBの仕組みを使いデータファイルにアクセスします
2. CreateObjectでADODBに接続することで、VB6のプロジェクトに参照設定しないでもいいようにします
3. クエリは、データをいったん「適用開始日の降順」に並べ替えて取得したあと、指定年月日以前のレコードを取出し、先頭のひとつを返すものになっています。
単純に、指定年月日以前のレコードを取出し、「適用開始日の降順」に並べ替えて、先頭のひとつを返す、でもいいんですけどね。
こんなクエリの書き方もあるということで何かのときの参考にしてください。
4. 実装するときには、渡された年月日が正しい形式になっているかどうか、データファイルが存在するかどうかなど、エラーチェックを追加してくださいね…
mdbから読込む場合のソースプログラム（クラスとして構築します）は下記のようになります。
onst 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 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の場合と同じです。