Adding DSN with VBA

Access is a popular choice for a database GUI. There is no need to know how to connect with a specific database from Access as long as we know how to use an ODBC connection. To make everything fully automated it is even possible to add such a connection with a simple VBA script, maybe not so simple but it is still possible.

This idea behind, is to edit the system registry using VBA. On the MSDN site there is a KB184608 document describing how to create a DSN connection for SQL Sever. Most of the code comes from there, but not all of it.

To be able to use functions defined in DLL files, we need to declare them at the very top of the VBA code.

Private Const REG_SZ = 1    
Private Const HKEY_CURRENT_USER = &H80000001
Private Const KEY_WRITE = &H20006

Private Declare Function RegDeleteKey Lib "advapi32.dll" _
   Alias "RegDeleteKeyA" ( _
   ByVal hKey As Long, _
   ByVal lpSubKey As String) As Long
  
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 RegSetValueEx Lib "advapi32.dll" Alias _
   "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal _
   cbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" _
   (ByVal hKey As Long) As Long
                    
Private Declare Function RegOpenKey Lib "advapi32.dll" _
   Alias "RegOpenKeyA" (ByVal hKey As Long, _
   ByVal lpSubKey As String, _
   phkResult As Long) As Long

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 RegDeleteValue Lib "advapi32.dll" Alias _
   "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

Now we defined two functions for dropping and adding DSN connection.

'' Function to delete existing DSN connection
'' with a specified name        
Private Sub DropDSN(ByVal DataSourceName As String)
   '' Create the new DSN key.
   Dim lResult As Long, handle As Long
   Dim DeleteRegistryValue As Long
   lResult = RegDeleteKey(HKEY_CURRENT_USER, _
                "SOFTWARE\ODBC\ODBC.INI\" & DataSourceName)
   If RegOpenKeyEx(HKEY_CURRENT_USER, _
         "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources\", _
         0, KEY_WRITE, handle) _
   Then
       Exit Sub
   Else
       '' Delete the value (returns 0 if success)
       DeleteRegistryValue = (RegDeleteValue(handle, _
                              DataSourceName) = 0)
   End If
End Sub
    
Private Sub AddDSN(ByVal username As String, _ 
                   ByVal pass As String, _
                   ByVal DSN As String)
    
    Dim DataSourceName, DriverName As String
    Dim lResult, hKeyHandle As Long
    
    '' Specify the DSN parameters.
    '' This is a name that will be displayed
    '' in the Control Panel -> ODBC Connections
    DataSourceName = DSN
    '' Here I create connection to PostgreSQL
    DriverName = "PostgreSQL Unicode"
    
    Dim d As New Scripting.Dictionary, x As Variant
    Dim Description  As String

    d.Add "Description", "My database description"
    d.Add "DriverName", DriverName
    d.Add "DataSourceName", DataSourceName
    d.Add "Database", "my_database"	
    d.Add "Servername", "127.0.0.1"
    d.Add "Port", "1234"
    d.Add "Username", username
    d.Add "UID", username
    d.Add "Password", pass
	'' You have to pass a DLL used to connect with your database
	'' in this example I create connection with PostgresSql.
    d.Add "Driver", "c:\Program Files\psqlODBC\0803\bin\" & _
                    "psqlodbc35w.dll"
    d.Add "CommLog", "1"
    d.Add "Debug", "0"
    d.Add "Fetch", "100"
    d.Add "Optimizer", "1"
    d.Add "Ksqo", "1"
    d.Add "UniqueIndex", "1"
    d.Add "UseDeclareFetch", "0"
    d.Add "UnknownSizes", "0"
    d.Add "TextAsLongVarchar", "1"
    d.Add "UnknownsAsLongVarchar", "0"
    d.Add "BoolsAsChar", "0"
    d.Add "Parse", "0"
    d.Add "CancelAsFreeStmt", "0"
    d.Add "MaxVarcharSize", "255"
    d.Add "MaxLongVarcharSize", "8190"
    d.Add "ExtraSysTablePrefixes", "dd_;"
    d.Add "ReadOnly", "0"
    d.Add "ShowOidColumn", "0"
    d.Add "FakeOidIndex", "0"
    d.Add "RowVersioning", "0"
    d.Add "ShowSystemTables", "0"
    d.Add "Protocol", "7.4-1"
    d.Add "ConnSettings", " "
    d.Add "DisallowPremature", "0"
    d.Add "UpdatableCursors", "0"
    d.Add "LFConversion", "1"
    d.Add "TrueIsMinus1", "1"
    d.Add "BI", "0"
    d.Add "AB", "0"
    d.Add "ByteaAsLongVarBinary", "0"
    d.Add "UseServerSidePrepare", "0"
    d.Add "LowerCaseIdentifier", "0"
    d.Add "SSLmode", "prefer"
    d.Add "XaOpt", "1"

    
    '' Create the new DSN key.
    lResult = RegCreateKey(HKEY_CURRENT_USER, _
              "SOFTWARE\ODBC\ODBC.INI\" & _
              DataSourceName, hKeyHandle)

    '' Set the values of the new DSN key.
    For Each x In d
        lResult = RegSetValueEx(hKeyHandle, x,_
                  0&, REG_SZ, d(x), Len(d(x)))
    Next x

    '' Close the new DSN key.    
    lResult = RegCloseKey(hKeyHandle)
    
    '' Open ODBC Data Sources key to list the new DSN in 
    '' the ODBC Manager.
    '' Specify the new value.
    '' Close the key.    
    lResult = RegCreateKey(HKEY_CURRENT_USER, _
       "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKeyHandle)
    lResult = RegSetValueEx(hKeyHandle, DataSourceName, _
              0&, REG_SZ, ByVal DriverName, Len(DriverName))
    lResult = RegCloseKey(hKeyHandle)

End Sub

Now a short example how to use functions defined above. Lets name our ODBC connection CheckPSQL, with a custom username and password.

Private Function connect_and_do_something _
        (ByVal username As String, ByVal my_pass As String)

   '' This function creates ODBC connections
   Dim hKeyHandle As Long, 
   '' If our ODBC connection does not exist, create it
   If RegOpenKey(HKEY_CURRENT_USER, _
                "SOFTWARE\ODBC\ODBC.INI\CheckPSQL", _
                hKeyHandle) = 2 _
   Then
     AddDSN username, my_pass, "CheckPSQL"
   End If
   ''
   '' perform some action here
   ''
   '' If you do not want to leave a trace in the registry, 
   '' just delete the DSN settings
   DropDSN "CheckPSQL"
   Exit Function
odbc_trap:
    Dim err As Variant
    '' There can be many ODBC errors,
    '' so list all of them.
    For Each err In DAO.Errors
        Debug.Print "ODBC ERROR: " & err.Number & _
                    " : " & err.Description
    Next err
    DropDSN "CheckPSQL"

End Function

Of course we do not want Access to fetch all the data needed to perform the query. Hence, we need to specify a pass through query. But this will be covered in a different post.

Leave a Reply