Set ODBC using VB code
Hi.. Can I set ODBC user DSN by using VB code???
I use VB6 and crystal report v.8.0 and OS win 2000. I don't want to set ODBC to every computer I install my application.
I use VB6 and crystal report v.8.0 and OS win 2000. I don't want to set ODBC to every computer I install my application.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
HMMMM
DOE THIS WORK
'*************************
' Name: Create/Check Access' DSN in ODBC
'
' Description:Code You can use for check
' and (if not exist) create DSN for Access
' DB in ODBC.
' By: Tair Abdurman
'
'
' Inputs:None
'
' Returns:None
'
'Assumes:None
'
'Side Effects:None
'This code is copyrighted and has limite
' d warranties.
'Please see http://www.Planet-Source-Cod
' e.com/xq/ASP/txtCodeId.522
' vb/scripts/ShowCode.htm
'for details.
'*************************
'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_MA
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 = "SOFTWARE\ODBC\ODBCINST.IN
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(szWan
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim bRes As Boolean
szKeyPath = "SOFTWARE\ODBC\ODBC.INI\OD
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(szDriverNa
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_MA
"SOFTWARE\ODBC\ODBC.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 & "\DB\ssmdb.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 = "SOFTWARE\ODBC\ODBC.INI\" & szWantedDSN & "\Engines\Jet"
lRes = RegCreateKey(HKEY_LOCAL_MA
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_MA
"SOFTWARE\ODBC\ODBC.INI\OD
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(szDriver
MsgBox "You must Install Access ODBC Drivers before use this program.", vbOK + vbCritical
End If
'is our dsn exist?
If Not (checkWantedAccessDSN(szWa
If szDriverName = "" Then
MsgBox "Can't find access ODBC driver.", vbOK + vbCritical
Else
If Not createAccessDSN(szDriverNa
MsgBox "Can't create database ODBC.", vbOK + vbCritical
End If
End If
End If
DOE THIS WORK
'*************************
' Name: Create/Check Access' DSN in ODBC
'
' Description:Code You can use for check
' and (if not exist) create DSN for Access
' DB in ODBC.
' By: Tair Abdurman
'
'
' Inputs:None
'
' Returns:None
'
'Assumes:None
'
'Side Effects:None
'This code is copyrighted and has limite
' d warranties.
'Please see http://www.Planet-Source-Cod
' e.com/xq/ASP/txtCodeId.522
' vb/scripts/ShowCode.htm
'for details.
'*************************
'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_MA
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 = "SOFTWARE\ODBC\ODBCINST.IN
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(szWan
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim bRes As Boolean
szKeyPath = "SOFTWARE\ODBC\ODBC.INI\OD
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(szDriverNa
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_MA
"SOFTWARE\ODBC\ODBC.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 & "\DB\ssmdb.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 = "SOFTWARE\ODBC\ODBC.INI\" & szWantedDSN & "\Engines\Jet"
lRes = RegCreateKey(HKEY_LOCAL_MA
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_MA
"SOFTWARE\ODBC\ODBC.INI\OD
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(szDriver
MsgBox "You must Install Access ODBC Drivers before use this program.", vbOK + vbCritical
End If
'is our dsn exist?
If Not (checkWantedAccessDSN(szWa
If szDriverName = "" Then
MsgBox "Can't find access ODBC driver.", vbOK + vbCritical
Else
If Not createAccessDSN(szDriverNa
MsgBox "Can't create database ODBC.", vbOK + vbCritical
End If
End If
End If
OOOOPS SORRY HAD PROBLEMS SUBMITTING,
DOES THAT CODE Help any
DOES THAT CODE Help any
This code creates a system DSN, some small changes should allow you to create a user DSN
http://www.freevbcode.com/ShowCode.Asp?ID=502
Incidentally why do you need to create a user DSN. It sounds to me as if this is a good use for a DSNless connection as in this example:
http://www.freevbcode.com/ShowCode.Asp?ID=1257
Good Luck
Andrew
http://www.freevbcode.com/ShowCode.Asp?ID=502
Incidentally why do you need to create a user DSN. It sounds to me as if this is a good use for a DSNless connection as in this example:
http://www.freevbcode.com/ShowCode.Asp?ID=1257
Good Luck
Andrew
You might want to create a DSN (either system or user) in your setup program (using something like the code others have provided) - a good option if you just want to avoid the hassle of setting up the DSN, but want to retain the flexibility of having one. You could use a DSN-less connection (as suggested by Andrew) - generally a more sensible idea than having your actual program create a DSN on the fly.
However, if your app is going to be installed within your own organisation, on a number of machines on a LAN, another option is to use a file DSN located on a network share on a server. Your setup program can install a registry entry that the program reads to find out where to look for the file DSN. Then, every machine in the place is working from the same DSN, and if your database changes - say, your server goes belly-up and you have to restore your database to a different server - you just change the one file, and you're good to go.
However, if your app is going to be installed within your own organisation, on a number of machines on a LAN, another option is to use a file DSN located on a network share on a server. Your setup program can install a registry entry that the program reads to find out where to look for the file DSN. Then, every machine in the place is working from the same DSN, and if your database changes - say, your server goes belly-up and you have to restore your database to a different server - you just change the one file, and you're good to go.
ping..
' For Setup ODBC DSN
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.dll" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
Public Sub CreateSQLODBCSysDSN(ByVal DSN_Name As String, ByVal SQLServerName As String, Optional ByVal DefaultDatabase As String, Optional ByVal NTLogin As Boolean)
Dim lngRet As Long
Dim strAttributes As String
Dim DefaultDB As String
' Default Database parameter checking
If Trim(DefaultDatabase) = "" Then
DefaultDB = "master"
Else
DefaultDB = DefaultDatabase
End If
'Set the detail of DSN
strAttributes = "Dsn=" & DSN_Name & Chr$(0) & "Server=" & SQLServerName & Chr$(0) & "Database=" & DefaultDB & Chr$(0)
' True - NT Authentication; False - SQL Server Authentication
If NTLogin Then
strAttributes = strAttributes & "Trusted_Connection=Yes" & Chr(0)
Else
strAttributes = strAttributes & "Trusted_Connection=No" & Chr(0)
End If
'Create DSN
'0& = Null, 4 = Add a System DataSource
lngRet = SQLConfigDataSource(0&, 4, "SQL Server", strAttributes)
If lngRet = 0 Then
Err.Raise 32730, , "Cannot create ODBC system DSN " & DSN_Name & " for SQL Server " & SQLServerName
End If
End Sub
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.dll" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
Public Sub CreateSQLODBCSysDSN(ByVal DSN_Name As String, ByVal SQLServerName As String, Optional ByVal DefaultDatabase As String, Optional ByVal NTLogin As Boolean)
Dim lngRet As Long
Dim strAttributes As String
Dim DefaultDB As String
' Default Database parameter checking
If Trim(DefaultDatabase) = "" Then
DefaultDB = "master"
Else
DefaultDB = DefaultDatabase
End If
'Set the detail of DSN
strAttributes = "Dsn=" & DSN_Name & Chr$(0) & "Server=" & SQLServerName & Chr$(0) & "Database=" & DefaultDB & Chr$(0)
' True - NT Authentication; False - SQL Server Authentication
If NTLogin Then
strAttributes = strAttributes & "Trusted_Connection=Yes" & Chr(0)
Else
strAttributes = strAttributes & "Trusted_Connection=No" & Chr(0)
End If
'Create DSN
'0& = Null, 4 = Add a System DataSource
lngRet = SQLConfigDataSource(0&, 4, "SQL Server", strAttributes)
If lngRet = 0 Then
Err.Raise 32730, , "Cannot create ODBC system DSN " & DSN_Name & " for SQL Server " & SQLServerName
End If
End Sub
Public Sub RemoveSysDSN(ByVal DSN_Name As String)
Dim lngRet As Long
Dim strAttributes As String
Dim DefaultDB As String
'Set the detail of DSN
strAttributes = "Dsn=" & DSN_Name & Chr$(0)
' Remove DSN
' 0& = Null, 6 = Remove a System DataSource
lngRet = SQLConfigDataSource(0&, 6, "SQL Server", strAttributes)
If lngRet = 0 Then
Err.Raise 32731, , "Cannot remove ODBC system DSN " & DSN_Name
End If
End Sub
Dim lngRet As Long
Dim strAttributes As String
Dim DefaultDB As String
'Set the detail of DSN
strAttributes = "Dsn=" & DSN_Name & Chr$(0)
' Remove DSN
' 0& = Null, 6 = Remove a System DataSource
lngRet = SQLConfigDataSource(0&, 6, "SQL Server", strAttributes)
If lngRet = 0 Then
Err.Raise 32731, , "Cannot remove ODBC system DSN " & DSN_Name
End If
End Sub
DOE THIS WORK
'*************************
' Name: Create/Check Access' DSN in ODBC
'
' Description:Code You can use for check
' and (if not exist) create DSN for Access
' DB in ODBC.
' By: Tair Abdurman
'
'
' Inputs:None
'
' Returns:None
'
'Assumes:None
'
'Side Effects:None
'This code is copyrighted and has limite
' d warranties.
'Please see http://www.Planet-Source-Cod
' e.com/xq/ASP/txtCodeId.522
' vb/scripts/ShowCode.htm
'for details.
'*************************
'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_MA
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 = "SOFTWARE\ODBC\ODBCINST.IN
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(szWan
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim bRes As Boolean
szKeyPath = "SOFTWARE\ODBC\ODBC.INI\OD
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(szDriverNa
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_MA
"SOFTWARE\ODBC\ODBC.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 & "\DB\ssmdb.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 = "SOFTWARE\ODBC\ODBC.INI\" & szWantedDSN & "\Engines\Jet"
lRes = RegCreateKey(HKEY_LOCAL_MA
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_MA
"SOFTWARE\ODBC\ODBC.INI\OD
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(szDriver
MsgBox "You must Install Access ODBC Drivers before use this program.", vbOK + vbCritical
End If
'is our dsn exist?
If Not (checkWantedAccessDSN(szWa
If szDriverName = "" Then
MsgBox "Can't find access ODBC driver.", vbOK + vbCritical
Else
If Not createAccessDSN(szDriverNa
MsgBox "Can't create database ODBC.", vbOK + vbCritical
End If
End If
End If