Should be able to use this in VBA.
Below is the function I use in a command button click event on a form to create the DSN(s). Below that is the
module code that does the work. I use an option box and text box to allow a different default database to be
selected, you may not need that. Modify the call to CreateDSN to suit.
'******************Begin Form Code
Private Sub cmdCreateDSN_Click()
Dim strSQLServerDLLPath As String
Dim strDefaultDB As String
If optMaster Then
strDefaultDB = "master"
Else
If Len(txtDefaultDB) = 0 Then
MsgBox "Must specify other db"
Exit Sub
Else
strDefaultDB = txtDefaultDB.Text
End If
End If
strSQLServerDLLPath = RegistryGetKeyValue(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBCINST.INI\SQL Server", "Driver")
'system dsn, same name as server
'delete the key and values if exists
RegDeleteKey HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\Server1"
RegistryDeleteValue HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", "Server1"
'create new dsn
CreateDSN "Server1", "SQL Server Databases on Server1", _
"Server1", strDefaultDB, _
"SQL Server", strSQLServerDLLPath, _
"Network", "Yes"
'system dsn, name is different than server
'delete the key and values if exists
RegDeleteKey HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\ProductionDB"
RegistryDeleteValue HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", "ProductionDB"
CreateDSN "ProductionDB", "Production SQL Server Databases on Server2", _
"Server2", strDefaultDB, _
"SQL Server", strSQLServerDLLPath, _
"Network", "Yes"
MsgBox "DSN's Created, please test and confirm configuration.", vbInformation, "DSN's Created"
End Sub
'******************End Form Code
Here is the code for a module (basDSN):
'******************Begin Module Code
Option Explicit
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG_SZ = 1 'Constant for a string variable type.
Public Const REG_DWORD As Long = 4
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias _
"RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _
phkResult As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal _
cbData As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
"RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
"RegDeleteValueA" (ByVal lngHKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As String, lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As Long, lpcbData As Long) As Long
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
Public Sub CreateDSN(DataSourceName As String, Description As String, _
Server As String, DatabaseName As String, _
DriverName As String, DriverPath As String, _
LastUser As String, TrustedConnect As String)
Dim lResult As Long
Dim hKeyHandle As Long
'Specify the DSN parameters.
'DataSourceName = "<the name of your new DSN>"
'DatabaseName = "<name of the database to be accessed by the new DSN>"
'Description = "<a description of the new DSN>"
'DriverPath = "<path to your SQL Server driver>"
'LastUser = "<default user ID of the new DSN>"
'Server = "<name of the server to be accessed by the new DSN>"
'DriverName = "SQL Server"
'TrustedConnection = <Yes or No>
'Create the new DSN key.
lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & _
DataSourceName, hKeyHandle)
'Set the values of the new DSN key.
lResult = RegSetValueEx(hKeyHandle, "Database", 0&, REG_SZ, _
ByVal DatabaseName, Len(DatabaseName))
lResult = RegSetValueEx(hKeyHandle, "Description", 0&, REG_SZ, _
ByVal Description, Len(Description))
lResult = RegSetValueEx(hKeyHandle, "Driver", 0&, REG_SZ, _
ByVal DriverPath, Len(DriverPath))
lResult = RegSetValueEx(hKeyHandle, "LastUser", 0&, REG_SZ, _
ByVal LastUser, Len(LastUser))
lResult = RegSetValueEx(hKeyHandle, "Server", 0&, REG_SZ, _
ByVal Server, Len(Server))
lResult = RegSetValueEx(hKeyHandle, "Trusted_Connection", 0&, REG_SZ, _
ByVal TrustedConnect, Len(TrustedConnect))
'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_LOCAL_MACHINE, _
"SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKeyHandle)
lResult = RegSetValueEx(hKeyHandle, DataSourceName, 0&, REG_SZ, _
ByVal DriverName, Len(DriverName))
lResult = RegCloseKey(hKeyHandle)
End Sub
Public Sub RegistryDeleteValue( _
lngRootKey As Long, _
strKeyName As String, _
strValueName As String)
Dim lResult As Long
Dim hKeyHandle As Long
' Open the key
lResult = RegCreateKey(lngRootKey, strKeyName, hKeyHandle)
' If the key was opened successfully, then delete it
If lResult = 0 Then
lResult = RegDeleteValue(hKeyHandle, strValueName)
End If
lResult = RegCloseKey(hKeyHandle)
End Sub
Public Function RegistryGetKeyValue(lngRootKey As Long, sKeyName As String, sValueName As String)
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
Const KEY_ALL_ACCESS = &H3F
lRetVal = RegOpenKeyEx(lngRootKey, sKeyName, 0, _
KEY_ALL_ACCESS, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
'MsgBox vValue
RegCloseKey (hKey)
RegistryGetKeyValue = vValue
End Function
Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
On Error GoTo QueryValueExError
' Determine the size and type of data to be read
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5
Select Case lType
' For strings
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch - 1)
Else
vValue = Empty
End If
' For DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'all other data types not supported
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function
'******************End Module Code
