When developing Access databases, one of the things I have noticed I have sometimes needed to do is to store information about the database itself in key/value. Some examples:
The date the database was last accessed
The date and time an import routine was last run
User preference information
There are a lot of ways to store this information, e.g. in the Registry, in an .ini table. My preferred way of storing it would be a standard Access table, but they aren't really set up for storing data this manner. The way I worked around this is I created two routines - one to store key/value data in a predefined table, and one to read it back at out.
The subroutine StoreDBInfo takes two inputs - a key name and a value. It stores that information in tblDB_Info. The function GetDBInfo has a single input - the key name and it outputs the value for that specific key. If no value was stored, it raises an error.
For examples, the following code:
Public Sub Test()
StoreDBInfo "User Name", "Matt Harris"
MsgBox (GetDBInfo("User Name"))
End Sub
creates a Key of "User Name" in tblDB_Info and stores the value of "Matt Harris" next to it. It then reads that Value stored with that Key and pops up a msgbox with that value:
In order to use these routines in Access:
Create a new module in Access.
Copy the "Key/Value Lookup code" below into that module.
Run the routine CreateDBInfoTableonce. It creates the table "tblDB_Info".
Call StoreDBInfo with appropriate inputs when you wish to store data.
Call GetDBInfo with the appropriate key to read the data back out.
'---------------Key/Value Lookup code----------------
'
'The following code uses DAO, so make sure that under Tools | References
'you have "Microsoft DAO 3.6 Object Library" checked, or
'whatever is the appropriate version for your vesion of Access.
'
'If you have ADO also checked, make sure the DAO reference comes first
Option Compare Database
Option Explicit
Private Const DB_Info_Table As String = "tblDB_Info"
Public Sub StoreDBInfo(KeyID As String, KeyValue As Variant)
On Error GoTo Error_Label
Dim rst As Recordset
Dim KeyType As Integer
Set rst = CurrentDb.OpenRecordset(DB_Info_Table, dbOpenDynaset)
rst.FindFirst "[KeyID]='" & KeyID & "'"
If rst.NoMatch Then 'If Key is not found, add it
rst.AddNew
Else
rst.Edit
End If
KeyType = VarType(KeyValue)
rst.Fields!KeyID = KeyID
rst.Fields!KeyValue = CStr(KeyValue)
rst.Fields!KeyType = KeyType
rst.Update
Exit_Label:
If Not IsEmpty(rst) Then rst.Close
Exit Sub
Error_Label:
MsgBox (Err.Number & Err.Description)
On Error GoTo 0
Resume Exit_Label
End SubPublic Function GetDBInfo(KeyID As String) As Variant
Dim rst As Recordset
Dim KeyType As Integer
Set rst = CurrentDb.OpenRecordset(DB_Info_Table, dbOpenDynaset)
rst.FindFirst "[KeyID]='" & KeyID & "'"
If rst.NoMatch Then
rst.Close
Set rst = Nothing
Err.Raise vbObjectError + 1, , "No such Key ID."
Else
KeyType = rst.Fields!KeyType
Select Case KeyType
Case vbNull
GetDBInfo = Null
Case vbInteger
GetDBInfo = CInt(rst.Fields!KeyValue)
Case vbLong
GetDBInfo = CLng(rst.Fields!KeyValue)
Case vbSingle
GetDBInfo = CSng(rst.Fields!KeyValue)
Case vbDouble
GetDBInfo = CDbl(rst.Fields!KeyValue)
Case vbCurrency
GetDBInfo = CCur(rst.Fields!KeyValue)
Case vbDate
GetDBInfo = CDate(rst.Fields!KeyValue)
Case vbString
GetDBInfo = rst.Fields!KeyValue
Case vbError
GetDBInfo = CVErr(rst.Fields!KeyValue)
Case vbBoolean
GetDBInfo = CBool(rst.Fields!KeyValue)
Case vbDecimal
GetDBInfo = CDec(rst.Fields!KeyValue)
Case vbByte
GetDBInfo = CByte(rst.Fields!KeyValue)
Case Else
rst.Close
Set rst = Nothing
Err.Raise vbObjectError + 2, , "Invalid data type in GetDBInfo."
End Select
End If
If Not IsEmpty(rst) Then rst.Close
End Function'The following subroutine only needs to be run once
'It creates the table "tblDB_Info" which is used by the routines
'StoreDBInfo and GetDBInfoPublic Sub CreateDBInfoTable()
On Error GoTo Err_Label
Dim SQL As String
SQL = "CREATE TABLE tblDB_Info (KeyID TEXT (50) CONSTRAINT PrimaryKey PRIMARY KEY, "
SQL = SQL & "KeyValue MEMO, KeyType INTEGER Not Null);"
DoCmd.RunSQL SQL
Exit_Label:
Exit Sub
Err_Label:
If Err.Number <> 3010 Then
MsgBox (Err.Number & " " & Err.Description)
Resume Next
Else '3010 means table already exists
Resume Next
End If
End Sub
Created on ... March 21, 2004
Last Modified ... April 10, 2004
