DAO 条件に一致するレコードを取得(Findメソッド)

VB&VBA
FROG ふろっぐ
 
  • オプション

    本文印刷

    お気に入りに追加

  • 検索

    Googlewwwjp-ia
     

    Googlewwwjp-ia
     
  • 情報

  • 関連

[VB&VBA][DAO 条件に一致するレコードを取得(Findメソッド)]
Option Explicit


Sub DAO_Find_Record()
'***********************************************
'DAO 条件に一致するレコードを取得(Findメソッド)
'***********************************************
'[Microsoft DAO 3.6 Object Library]参照設定

Dim objDtbs As DAO.Database
Dim objRcrd As DAO.Recordset
Dim strTblName As String
Dim strFilePath As String
Dim strFileName As String
Dim strFindFieldName As String
Dim strMatchFieldName(4) As String
Dim strSeek As String
Dim strSQL As String
Dim strMSG As String

strFilePath = ThisWorkbook.Path             'ファイルのパス
strFileName = "KEN_ALL.mdb"                 'ファイル名
strTblName = "KEN_ALL"                      'テーブル名
strFindFieldName = "フィールド3"            '検索フィールド名
strMatchFieldName(1) = "フィールド3"        '検索結果フィールド名
strMatchFieldName(2) = "フィールド7"        '検索結果フィールド名
strMatchFieldName(3) = "フィールド8"        '検索結果フィールド名
strMatchFieldName(4) = "フィールド9"        '検索結果フィールド名
strSeek = "0600008"                         '検索文字

'【エラートラップ】
On Error GoTo ThisERR:

'【データベースを開く】
Set objDtbs = OpenDatabase(strFilePath & "\" & strFileName)
'【指定テーブルのレコード取得】
Set objRcrd = objDtbs.OpenRecordset(strTblName)

objRcrd.FindFirst strFindFieldName & "=" & "'" & strSeek & "'"

If objRcrd.NoMatch = False Then
    strMSG = objRcrd.Fields(strMatchFieldName(1)) & vbCr
    strMSG = strMSG & objRcrd.Fields(strMatchFieldName(2)) & vbCr
    strMSG = strMSG & objRcrd.Fields(strMatchFieldName(3)) & vbCr
    strMSG = strMSG & objRcrd.Fields(strMatchFieldName(4))
    MsgBox strMSG, 0, strSeek
Else
    MsgBox "見つかりません", 0, strSeek
End If

'--------------------------------------------------------------
'メソッド       | 開始位置  | 検索方向  | 用途
'---------------|-----------|-----------|-----------------
'FindFirst      | 先頭      | 終端      | カレント
'FindLast       | 終端      | 先頭      | カレント
'FindNext       | カレント  | 終端      | 複数存在
'FindPrevious   | カレント  | 先頭      | 複数存在
'---------------|-----------|-----------|-----------------
'プロパティ     | 検索成功  | 検索失敗  |
'---------------|-----------|-----------|-----------------
'NoMatch        | False     | True      |
'---------------|-----------|-----------|-----------------
'演算子         | =,<,>,<=,>=
'--------------------------------------------------------------

'【レコードを閉じる】
objRcrd.Close
'【データベースを閉じる】
objDtbs.Close
' 【オブジェクト解放】
Set objRcrd = Nothing
Set objDtbs = Nothing

Exit Sub
'【エラートラップ】
ThisERR:

MsgBox "予期せぬエラーが発生しました。" & vbCrLf & Err.Description, vbCritical, "ErrNumber:" & Err.Number

End Sub






Production Japan Import Application. Since 1998