Why not bypass the ODBC dialog altogether and use the API? This sample will
dynamically write the DSN profile for SQL Server to the registry.
_________________________________________________
Option Compare Database
Option Explicit
Declare Function GetSystemDirectory Lib "kernel32" Alias
"GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA"
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
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
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private psProcedure As String
Private bSuccess As Boolean
_________________________________________________
Public Function Open_App()
bSuccess = RegisterDb(sDSN:="Common name", _
sDSNData:="SQL Server", _
sDSNDescription:="Common name description", _
sServerName:="Server ID", _
sServerNameData:="dbmssocn,Network ID", _
sDatabaseName:="Database name")
If bSuccess Then
' assign your connect string
End If
End Function
_________________________________________________
Private Function RegisterDb(ByVal sDSN As String, ByVal sDSNData As String,
ByVal sDSNDescription As String, ByVal sServerName As String, ByVal
sServerNameData As String, ByVal sDatabaseName As String) As Boolean
On Error GoTo Err_RegisterDb
Dim sSQLDriverPath As String
Dim hKeyHandle As Long
Dim lRetVal As Long
Const REG_SZ = 1
Const HKEY_LOCAL_MACHINE = &H80000002
bSuccess = GetDriver(sSQLDriverPath)
If bSuccess Then
lRetVal = RegCreateKey(HKEY_LOCAL_MACHINE,
"SOFTWARE\Microsoft\MSSQLServer\Client\ConnectTo", hKeyHandle)
lRetVal = RegSetValueEx(hKeyHandle, sServerName, 0&, REG_SZ, ByVal
sServerNameData, Len(sServerNameData))
lRetVal = RegCloseKey(hKeyHandle)
lRetVal = RegCreateKey(HKEY_LOCAL_MACHINE,
"SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKeyHandle)
lRetVal = RegSetValueEx(hKeyHandle, sDSN, 0&, REG_SZ, ByVal
sDSNData, Len(sDSNData))
lRetVal = RegCloseKey(hKeyHandle)
lRetVal = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\"
& sDSN, hKeyHandle)
lRetVal = RegSetValueEx(hKeyHandle, "Description", 0&, REG_SZ, ByVal
sDSNDescription, Len(sDSNDescription))
lRetVal = RegSetValueEx(hKeyHandle, "Server", 0&, REG_SZ, ByVal
sServerName, Len(sServerName))
lRetVal = RegSetValueEx(hKeyHandle, "Database", 0&, REG_SZ, ByVal
sDatabaseName, Len(sDatabaseName))
lRetVal = RegSetValueEx(hKeyHandle, "Driver", 0&, REG_SZ, ByVal
sSQLDriverPath, Len(sSQLDriverPath))
lRetVal = RegSetValueEx(hKeyHandle, "OemToAnsi", 0&, REG_SZ, ByVal
"No", Len("No"))
lRetVal = RegSetValueEx(hKeyHandle, "LastUser", 0&, REG_SZ, ByVal
"", 1)
lRetVal = RegSetValueEx(hKeyHandle, "Trusted_Connection", 0&,
REG_SZ, ByVal "No", Len("No"))
lRetVal = RegCloseKey(hKeyHandle)
End If
Exit_RegisterDb:
RegisterDb = bSuccess
Exit Function
Err_RegisterDb:
psProcedure = "basOpen :: RegisterDb"
MsgBox Err.Number & ": " & Err.Description, vbCritical, psProcedure
bSuccess = False
Resume Exit_RegisterDb
End Function
_________________________________________________
Private Function GetDriver(ByRef sSQLDriverPath As String) As Boolean
On Error GoTo Err_GetDriver
Dim sPath As String
Dim lDirectoryFound As Long
Dim iLength As Integer
Const MAX_LENGTH = 50
sPath = String(255, 0)
lDirectoryFound = GetSystemDirectory(sPath, MAX_LENGTH)
If lDirectoryFound Then
iLength = InStr(sPath, Chr$(0)) - 1
sSQLDriverPath = Left$(sPath, iLength) & "\sqlsrv32.dll"
bSuccess = True
Else
bSuccess = False
End If
Exit_GetDriver:
GetDriver = bSuccess
Exit Function
Err_GetDriver:
psProcedure = "basOpen :: GetDriver"
MsgBox Err.Number & ": " & Err.Description, vbCritical, psProcedure
bSuccess = False
Resume Exit_GetDriver
End Function
_________________________________________________
All the best,
Jim
