SSブログ

アクセス小僧:月ごとの領収書番号(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
ヤバイぜ!(1)  コメント(1)  トラックバック(0) 
共通テーマ:パソコン・インターネット

ヤバイぜ! 1

コメント 1

cheese999

' カレントレコードのレコード番号が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) 

コメントを書く

お名前:[必須]
URL:
コメント:
画像認証:
下の画像に表示されている文字(英大文字の「オー」、英小文字の「ユー」、アラビア数字の「ハチ」、アラビア数字の「イチ」、アラビア数字の「ニ」)を入力してください。

Facebook コメント

トラックバック 0

トラックバックの受付は締め切りました

この広告は前回の更新から一定期間経過したブログに表示されています。更新すると自動で解除されます。