Create/Check Access’ DSN in ODBC

By | 2002-06-01

Code You can use for check and (if not exist) create DSN for Access DB in ODBC.

Original Author: Tair Abdurman

Code

'in module file
Private Const KEY_QUERY_VALUE = &H1
Private Const ERROR_SUCCESS = 0&
Private Const REG_SZ = 1
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const REG_DWORD = 4
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long   ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Public Function isSZKeyExist(szKeyPath As String, _
        szKeyName As String, _
        ByRef szKeyValue As String) As Boolean
        
Dim bRes As Boolean
Dim lRes As Long
Dim hKey As Long
lRes = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
      szKeyPath, _
      0&, _
      KEY_QUERY_VALUE, _
      hKey)
If lRes <> ERROR_SUCCESS Then
isSZKeyExist = False
Exit Function
End If
lRes = RegQueryValueEx(hKey, _
      szKeyName, _
      0&, _
      REG_SZ, _
      ByVal szKeyValue, _
      Len(szKeyValue))
      
RegCloseKey (hKey)
If lRes <> ERROR_SUCCESS Then
isSZKeyExist = False
Exit Function
End If
isSZKeyExist = True
        
End Function
        
Public Function checkAccessDriver(ByRef szDriverName As String) As Boolean
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim bRes As Boolean


bRes = False

szKeyPath = "SOFTWAREODBCODBCINST.INIMicrosoft Access Driver (*.mdb)"
szKeyName = "Driver"
szKeyValue = String(255, Chr(32))

If isSZKeyExist(szKeyPath, szKeyName, szKeyValue) Then
  szDriverName = szKeyValue
  bRes = True
Else
  bRes = False
End If

checkAccessDriver = bRes
End Function
Public Function checkWantedAccessDSN(szWantedDSN As String) As Boolean
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim bRes As Boolean

szKeyPath = "SOFTWAREODBCODBC.INIODBC Data Sources"
szKeyName = szWantedDSN
szKeyValue = String(255, Chr(32))

If isSZKeyExist(szKeyPath, szKeyName, szKeyValue) Then
  bRes = True
Else
  bRes = False
End If

checkWantedAccessDSN = bRes

End Function
Public Function createAccessDSN(szDriverName As String, _
         szWantedDSN As String) As Boolean
        
Dim hKey As Long
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim lKeyValue As Long
Dim lRes As Long
Dim lSize As Long
Dim szEmpty As String

szEmpty = Chr(0)


lSize = 4
  
lRes = RegCreateKey(HKEY_LOCAL_MACHINE, _
      "SOFTWAREODBCODBC.INI" & _
      szWantedDSN, _
      hKey)

If lRes <> ERROR_SUCCESS Then
  createAccessDSN = False
  Exit Function
End If

lRes = RegSetValueExString(hKey, "UID", 0&, REG_SZ, _
  szEmpty, Len(szEmpty))

szKeyValue = App.Path & "DBssmdb.mdb"
lRes = RegSetValueExString(hKey, "DBQ", 0&, REG_SZ, _
  szKeyValue, Len(szKeyValue))
  
szKeyValue = szDriverName
lRes = RegSetValueExString(hKey, "Driver", 0&, REG_SZ, _
  szKeyValue, Len(szKeyValue))
  
szKeyValue = "MS Access;"
lRes = RegSetValueExString(hKey, "FIL", 0&, REG_SZ, _
  szKeyValue, Len(szKeyValue))
  
lKeyValue = 25
lRes = RegSetValueExLong(hKey, "DriverId", 0&, REG_DWORD, _
  lKeyValue, 4)

lKeyValue = 0
lRes = RegSetValueExLong(hKey, "SafeTransactions", 0&, REG_DWORD, _
  lKeyValue, 4)

lRes = RegCloseKey(hKey)
szKeyPath = "SOFTWAREODBCODBC.INI" & szWantedDSN & "EnginesJet"

lRes = RegCreateKey(HKEY_LOCAL_MACHINE, _
      szKeyPath, _
      hKey)

If lRes <> ERROR_SUCCESS Then
  createAccessDSN = False
  Exit Function
End If
lRes = RegSetValueExString(hKey, "ImplicitCommitSync", 0&, REG_SZ, _
  szEmpty, Len(szEmpty))
  
szKeyValue = "Yes"
lRes = RegSetValueExString(hKey, "UserCommitSync", 0&, REG_SZ, _
  szKeyValue, Len(szKeyValue))
  
lKeyValue = 2048
lRes = RegSetValueExLong(hKey, "MaxBufferSize", 0&, REG_DWORD, _
  lKeyValue, 4)

lKeyValue = 5
lRes = RegSetValueExLong(hKey, "PageTimeout", 0&, REG_DWORD, _
  lKeyValue, 4)

lKeyValue = 3
lRes = RegSetValueExLong(hKey, "Threads", 0&, REG_DWORD, _
  lKeyValue, 4)

lRes = RegCloseKey(hKey)
lRes = RegCreateKey(HKEY_LOCAL_MACHINE, _
      "SOFTWAREODBCODBC.INIODBC Data Sources", _
      hKey)

If lRes <> ERROR_SUCCESS Then
  createAccessDSN = False
  Exit Function
End If

szKeyValue = "Microsoft Access Driver (*.mdb)"
lRes = RegSetValueExString(hKey, szWantedDSN, 0&, REG_SZ, _
  szKeyValue, Len(szKeyValue))

lRes = RegCloseKey(hKey)
createAccessDSN = True
End Function
'anywhere in application

Dim szDriverName As String
Dim szWantedDSN As String

szDriverName = String(255, Chr(32))
szWantedDSN = "MyAccess_ODBC"
'is access drivers installed?
If Not checkAccessDriver(szDriverName) Then
MsgBox "You must Install Access ODBC Drivers before use this program.", vbOK + vbCritical
End If

'is our dsn exist?
If Not (checkWantedAccessDSN(szWantedDSN)) Then
If szDriverName = "" Then
  MsgBox "Can't find access ODBC driver.", vbOK + vbCritical
Else
If Not createAccessDSN(szDriverName, szWantedDSN) Then
  MsgBox "Can't create database ODBC.", vbOK + vbCritical
End If
End If
End If

Author: dwirch

Derek Wirch is a seasoned IT professional with an impressive career dating back to 1986. He brings a wealth of knowledge and hands-on experience that is invaluable to those embarking on their journey in the tech industry.

Leave a Reply

Your email address will not be published. Required fields are marked *

This site uses Akismet to reduce spam. Learn how your comment data is processed.