アクセス小僧:月ごとの領収書番号(2) [コンピューター]
医療費控除の医療費を月ごとに集計するためのアクセスにおいて、月ごとの領収書番号を自動で入力するためのVBAですが、
何とか、形になったようなので、紹介します。
【やりたいこと】
・医療費を入力するフォームに設置したボタンをクリックしたら、適切な領収書番号を自動入力する。
・医療費テーブルに入力されている医療費の全レコードを調べて、同じ年月、日が入力しようとしているレコードの日付以下、かつ、IDが入力しようとしているレコードのIDより小さいレコードの内、IDが最大のレコードの『領収書番号+1』を、ボタンがクリックされたレコードの領収書番号に設定する。IDを含めて比較しているのは、同じ日に領収書が2枚以上ある場合を想定しているため。
・上記の条件に当てはまるレコードが無い場合、例えば、新しい月の1番目のレコードを入力する場合は、ボタンがクリックされたレコードの領収書番号に『1』を設定する。
【VBAのコード】
・標準モジュールに『SetRyouSyuNo1』Functionを記述する。
Public Function SetRyouSyuNo1(Optional Ctl As Control, Optional Ctl2 As Control, _
Optional MyDate2 As Date, Optional myID As Integer) As Integer
' 【機能】月が変わったら、領収書番号を1にする
' 【引数】
' Ctl : 日付のコントロール
' Ctl2 : 領収書番号のコントロール
' MyDate2 : 現在のレコードの日付
' myID : ID
' 【変数】
Dim myDate1(2) As Date ' 日付
Dim myYear1(2) As Integer ' 年
Dim myMonth1(2) As Integer ' 月
Dim myDay1(2) As Integer ' 日
Dim myRyNo1(2) As Integer ' 領収書番号
Dim db1 As DAO.Database ' データベース
Dim rs1 As DAO.Recordset ' レコードセット
Dim rcdNo1 As Long ' レコード番号
Dim myID1 As Integer ' ID
' 【コード】
' カレントレコードのレコード番号が1以下だったら、終了
If CodeContextObject.CurrentRecord <= 1 Then Exit Function
' 現在のレコードの年、月、日
myYear1(1) = Year(MyDate2)
myMonth1(1) = Month(MyDate2)
myDay1(1) = Day(MyDate2)
' 医療費テーブルをレコードセットとして開く
Set db1 = CurrentDb()
' dbOpenTableだと、absolutepositionが使えない
' Set rs1 = db1.OpenRecordset("T_医療費", dbOpenTable)
Set rs1 = db1.OpenRecordset("T_医療費", dbOpenDynaset)
' 最大の領収書番号
myRyNo1(2) = 0
' myIDがnullなら、9999にしておく
If IsNull(myID) Then
myID1 = 9999
Else
myID1 = myID
End If
' 同じ年月のレコードの領収書番号で最大のものを探す
Do Until rs1.EOF
' レコードの年、月、日
myYear1(0) = Year(rs1!日付)
myMonth1(0) = Month(rs1!日付)
myDay1(0) = Day(rs1!日付)
' 同じ年月、かつ、日が現在のレコード以下
If (myYear1(0) = myYear1(1)) And (myMonth1(0) = myMonth1(1)) And (myDay1(0) <= myDay1(1)) Then
' IDが現在のレコードより小さい
If rs1!ID < myID1 Then
' 領収書番号が最大なら、更新
If rs1!領収書番号 > myRyNo1(2) Then
myRyNo1(2) = rs1!領収書番号
MsgBox ("日付=" & rs1!日付 & vbCrLf & _
"領収書番号=" & rs1!領収書番号 & vbCrLf & _
"ID=" & rs1!ID & vbCrLf & _
"レコード番号=" & rs1.AbsolutePosition)
End If
End If
End If
rs1.MoveNext
Loop
' レコードセットを閉じる
rs1.Close: Set rs1 = Nothing
db1.Close: Set db1 = Nothing
' MsgBox (myRyNo1(2)) ' debug
SetRyouSyuNo1 = myRyNo1(2) + 1
End Function
・医療費を入力するフォームに設置したボタンをクリックしたときに起動されるマクロを次のように記述する。
Private Sub コマンド32_Click()
If IsNull([ID]) Then
' 新規レコードでは、IDがnullなので、9999としておく
[領収書番号] = SetRyouSyuNo1([日付], [領収書番号], [日付], 9999)
Else
[領収書番号] = SetRyouSyuNo1([日付], [領収書番号], [日付], [ID])
End If
End Sub
何とか、形になったようなので、紹介します。
【やりたいこと】
・医療費を入力するフォームに設置したボタンをクリックしたら、適切な領収書番号を自動入力する。
・医療費テーブルに入力されている医療費の全レコードを調べて、同じ年月、日が入力しようとしているレコードの日付以下、かつ、IDが入力しようとしているレコードのIDより小さいレコードの内、IDが最大のレコードの『領収書番号+1』を、ボタンがクリックされたレコードの領収書番号に設定する。IDを含めて比較しているのは、同じ日に領収書が2枚以上ある場合を想定しているため。
・上記の条件に当てはまるレコードが無い場合、例えば、新しい月の1番目のレコードを入力する場合は、ボタンがクリックされたレコードの領収書番号に『1』を設定する。
【VBAのコード】
・標準モジュールに『SetRyouSyuNo1』Functionを記述する。
Public Function SetRyouSyuNo1(Optional Ctl As Control, Optional Ctl2 As Control, _
Optional MyDate2 As Date, Optional myID As Integer) As Integer
' 【機能】月が変わったら、領収書番号を1にする
' 【引数】
' Ctl : 日付のコントロール
' Ctl2 : 領収書番号のコントロール
' MyDate2 : 現在のレコードの日付
' myID : ID
' 【変数】
Dim myDate1(2) As Date ' 日付
Dim myYear1(2) As Integer ' 年
Dim myMonth1(2) As Integer ' 月
Dim myDay1(2) As Integer ' 日
Dim myRyNo1(2) As Integer ' 領収書番号
Dim db1 As DAO.Database ' データベース
Dim rs1 As DAO.Recordset ' レコードセット
Dim rcdNo1 As Long ' レコード番号
Dim myID1 As Integer ' ID
' 【コード】
' カレントレコードのレコード番号が1以下だったら、終了
If CodeContextObject.CurrentRecord <= 1 Then Exit Function
' 現在のレコードの年、月、日
myYear1(1) = Year(MyDate2)
myMonth1(1) = Month(MyDate2)
myDay1(1) = Day(MyDate2)
' 医療費テーブルをレコードセットとして開く
Set db1 = CurrentDb()
' dbOpenTableだと、absolutepositionが使えない
' Set rs1 = db1.OpenRecordset("T_医療費", dbOpenTable)
Set rs1 = db1.OpenRecordset("T_医療費", dbOpenDynaset)
' 最大の領収書番号
myRyNo1(2) = 0
' myIDがnullなら、9999にしておく
If IsNull(myID) Then
myID1 = 9999
Else
myID1 = myID
End If
' 同じ年月のレコードの領収書番号で最大のものを探す
Do Until rs1.EOF
' レコードの年、月、日
myYear1(0) = Year(rs1!日付)
myMonth1(0) = Month(rs1!日付)
myDay1(0) = Day(rs1!日付)
' 同じ年月、かつ、日が現在のレコード以下
If (myYear1(0) = myYear1(1)) And (myMonth1(0) = myMonth1(1)) And (myDay1(0) <= myDay1(1)) Then
' IDが現在のレコードより小さい
If rs1!ID < myID1 Then
' 領収書番号が最大なら、更新
If rs1!領収書番号 > myRyNo1(2) Then
myRyNo1(2) = rs1!領収書番号
MsgBox ("日付=" & rs1!日付 & vbCrLf & _
"領収書番号=" & rs1!領収書番号 & vbCrLf & _
"ID=" & rs1!ID & vbCrLf & _
"レコード番号=" & rs1.AbsolutePosition)
End If
End If
End If
rs1.MoveNext
Loop
' レコードセットを閉じる
rs1.Close: Set rs1 = Nothing
db1.Close: Set db1 = Nothing
' MsgBox (myRyNo1(2)) ' debug
SetRyouSyuNo1 = myRyNo1(2) + 1
End Function
・医療費を入力するフォームに設置したボタンをクリックしたときに起動されるマクロを次のように記述する。
Private Sub コマンド32_Click()
If IsNull([ID]) Then
' 新規レコードでは、IDがnullなので、9999としておく
[領収書番号] = SetRyouSyuNo1([日付], [領収書番号], [日付], 9999)
Else
[領収書番号] = SetRyouSyuNo1([日付], [領収書番号], [日付], [ID])
End If
End Sub
' カレントレコードのレコード番号が1以下だったら、終了
If CodeContextObject.CurrentRecord <= 1 Then Exit Function
の部分ですが、
' カレントレコードのレコード番号が1以下だったら、終了
If CodeContextObject.CurrentRecord <= 1 Then
SetRyouSyuNo1 = 1
Exit Function
End If
としたほうが良いかもしれません。そうでないと、領収書番号が0になってしまう場合がありますので。
by cheese999 (2017-01-09 00:22)