アクセス小僧：履歴を残す(5)

アクセス小僧：履歴を残す(2)
https://cheese999.blog.so-net.ne.jp/2018-10-05

で紹介した、【選択した履歴のレコードへ飛ぶためのマクロ】ですが、フィルタが、かかったままで実行すると、エラーになってしまうことが分かりました。



そこで、フィルタ解除のコードを追加しました。

【手順】
1. 履歴のコンボボックス(PW_Mng_ID履歴)が選択されてなかったら、マクロ終了
2. コンボボックスの何番目(ListIndex)が選択されているかを元に、履歴テーブル(T_PWMngID)を検索し、選択されたレコードのID(PW_Mng_IDt)を調べる
3. 選択されたレコードのID(PW_Mng_IDt)を元に、テーブル(T_パスワード管理)を検索し、レコード番号(AbsPos1, 先頭レコードは0)を得る
4. フィルタ解除 <= 今回追加
5. レコード番号(AbsPos1)を元に、フォーム(パスワード入力)上で、そのレコードに移動

【選択した履歴のレコードへ飛ぶためのマクロ】

Private Sub PW_Mng_ID履歴Go_Click()
  '【変数】
  Dim Ans1 As Long ' 答え
  Dim PW_Mng_IDt As Long ' 履歴上のID
  Dim AbsPos1 As Long 'レコード番号
  Dim Str1 As String ' 文字列
  '【実行コード】
  If [PW_Mng_ID履歴].ListIndex = -1 Then
    Ans1 = MsgBox("PW_Mng_ID履歴が選択されていません。", vbCritical, "エラー")
    Exit Sub
  End If
  Str1 = "T_PM_ID = " & CStr([PW_Mng_ID履歴].ListIndex + 1)
  PW_Mng_IDt = DLookup("PW_Mng_ID1", "T_PWMngID", Str1)
  Debug.Print "[PW_Mng_ID履歴].ListIndex=" & [PW_Mng_ID履歴].ListIndex & " PW_Mng_IDt=" & PW_Mng_IDt
  AbsPos1 = IDtoAbsPos1("T_パスワード管理", "PW_Mng_ID", PW_Mng_IDt)
  Me.AllowAdditions = True '追加の許可
  Me.FilterOn = False ' フィルタ解除
  If AbsPos1 <> -1 Then
    [チェック_ID履歴] = True
    DoCmd.GoToRecord acDataForm, "パスワード入力", acGoTo, AbsPos1 + 1
    [チェック_ID履歴] = False
  End If
  ' With Me.Recordset
  ' .FindFirst "PW_Mng_ID = " & PW_Mng_IDt
  ' End With
End Sub

【指定されたIDをテーブルで検索、見つかったらレコード番号を返すマクロ】

Function IDtoAbsPos1(NmTable1 As String, NmField1 As String, ID1 As Long) As Long
  '【機能】指定されたIDをテーブルで検索、見つかったらレコード番号を返す
  '【引数】
  ' NmTable1 : テーブル名
  ' NmField1 : フィールド名
  ' ID1 : 主キー
  '【返り値】
  ' レコード番号（返すレコード番号が無いときは、-1）
  '【変数】
  Dim db1 As DAO.Database ' データベース
  Dim rs1 As DAO.Recordset ' レコードセット
  Dim AbsPos1 As Long 'レコード番号
  Dim Ans1 As Long ' 答え
  '【実行コード】
  ' テーブルをレコードセットとして開く
  Set db1 = CurrentDb()
  Set rs1 = db1.OpenRecordset(NmTable1, dbOpenDynaset)
  rs1.MoveFirst ' 先頭レコードへ
  rs1.MoveLast ' 最終レコードへ
  rs1.MoveFirst ' 先頭レコードへ
  rs1.FindFirst NmField1 & " = " & ID1
  If rs1.NoMatch Then
    Ans1 = MsgBox(NmField1 & " = " & ID1 & "がありません。", vbCritical, "エラー")
    Set rs1 = Nothing
    Set db1 = Nothing
    IDtoAbsPos1 = -1
    Exit Function
  End If
  AbsPos1 = rs1.AbsolutePosition
  Set rs1 = Nothing
  Set db1 = Nothing
  IDtoAbsPos1 = AbsPos1
End Function

タグ：フィルタ 履歴 VBA アクセス

コメント 1

ヤバイぜ！　ありがとうございます(^_0)ノ
by cheese999 (2018-12-09 08:24)