Option Explicit
Dim ws As Workspace
Dim db As Database
Dim TimeOutValue As Integer

Private Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
Dim hNewKey As Long 'handle to the new key
Dim lRetVal As Long 'result of the RegCreateKeyEx function

lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, _
vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
0&, hNewKey, lRetVal)
RegCloseKey (hNewKey)
End Sub

Private Sub SetKeyValue(sKeyName As String, sValueName As String, _
vValueSetting As Variant)
Dim lRetVal As Long 'result of the SetValueExLong function
Dim hKey As Long 'handle of open key

lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, _
KEY_ALL_ACCESS, hKey)
lRetVal = RegSetValueExLong(hKey, sValueName, 0&, _
REG_DWORD, vValueSetting, 4)
RegCloseKey (hKey)
End Sub

Private Function QueryValue(sKeyName As String, sValueName As String) _
As Integer
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim vValue As Variant 'setting of queried value

lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, _
KEY_ALL_ACCESS, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
If lRetVal = ERROR_NONE Then
QueryValue = True
TimeOutValue = vValue
Else
QueryValue = False
End If
RegCloseKey (hKey)
End Function

Private Sub Command1_Click()
If QueryValue("Software\MyApp\Jet\3.5\Engines\ODBC", _
"ConnectionTimeout") Then
If TimeOutValue <> 1 Then
SetKeyValue "Software\MyApp\Jet\3.5\Engines\ODBC", _
"ConnectionTimeout", 1
End If
MsgBox "Test registry key already set"
Else
CreateNewKey "Software\MyApp\Jet\3.5\Engines\ODBC", _
HKEY_LOCAL_MACHINE
SetKeyValue "Software\MyApp\Jet\3.5\Engines\ODBC", _
"ConnectionTimeout", 1
MsgBox "Test registry key created successfully"
End If
End Sub

Private Sub Command2_Click()
Dim strConnect As String

DBEngine.IniPath = "HKEY_LOCAL_MACHINE\Software\MyApp\Jet\3.5"
Set ws = DBEngine.Workspaces(0)
strConnect = "ODBC;SERVER=MyServer;" & _
"DRIVER={SQL SERVER};DATABASE=pubs;UID=sa;PWD=;"
Set db = ws.OpenDatabase("", False, False, strConnect)
MsgBox "Connection established"
End Sub

Private Sub Command3_Click()
If db Is Nothing Then
MsgBox "Already Disconnected"
Exit Sub
End If

db.Close
ws.Close

Dim Start As Long
Start = Timer
Do
DBEngine.Idle dbFreeLocks
DoEvents
Loop While Timer <= Start + 1
MsgBox "Disconnected"
End Sub

Private Sub Form_Load()
Command1.Caption = "Create/Set test registry entry"
Command2.Caption = "Open database"
Command3.Caption = "Close database"
End Sub