Microsoft recommends that application data for "All Users" use the "ProgramData" directory. But if you have ever tried to create a DSN in this directory using the ODBC Manager, you have discovered that directory is not available. The reason is that particular directory is configured as hidden. But it is quite easy to do it programatically.
Microsoft still does not offer 64 bit drivers for anything but SQLServer, but at least Win 8.1 shows both the 32 bit & 64 bit ODBC Managers.
J.A. Coutts
Code:
Option Explicit
Private DataPath As String
Private DataBase As String
Private AllUserPath As String
Private adoConn1 As ADODB.Connection
Private ADOConnStr1 As String
Private Const ODBC_ADD_DSN = 1 ' Add user data source
Private Const ODBC_CONFIG_DSN = 2 ' Modify user data source
Private Const ODBC_REMOVE_DSN = 3 ' Delete user data source
Private Const ODBC_ADD_SYS_DSN = 4 ' System DSN functions only work
Private Const ODBC_CONFIG_SYS_DSN = 5 ' when logged in as administrator
Private Const ODBC_REMOVE_SYS_DSN = 6
Private Const ODBC_REMOVE_DEFAULT_DSN = 7
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Function SQLConfigDataSource Lib "odbccp32.dll" (ByVal hWndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
Private Function LocalInit() As Long
' Purpose:
' Starting point for application.
' =====================================================
Dim TaskID As Long
Dim sErr As Variant
Const sProc As String = "LocalInit"
On Error GoTo LocalInitErr
DataBase = "New_DB"
AllUserPath = "C:\ProgramData\NewApp\"
DataPath = AllUserPath & "NewDB.mdb"
'Verify database exists
TaskID = TestFile(AllUserPath, "NewDB.mdb")
If Not GetDSN(DataBase, "Microsoft Access Driver (*.mdb)", DataPath, ODBC_ADD_SYS_DSN) Then
Err.Raise 53 'File Not Found
End If
ADOConnStr1 = "DSN=" + DataBase + ";uid=;pwd=;database='tblNew';"
Set adoConn1 = CreateObject("ADODB.Connection")
adoConn1.Open ADOConnStr1
LocalInit = False
Exit Function
LocalInitErr:
sErr = Err
LocalInit = sErr
End Function
Private Function TestFile(PathName As String, FileName As String) As Boolean
Dim lngRet As Long
On Error GoTo TestFileErr
If Len(Dir(PathName & FileName)) = 0 Then
MkDir AllUserPath
lngRet = MsgBox("Database not Found!" & vbCrLf & "Copy blank one?", vbYesNo)
If lngRet = vbYes Then
FileCopy App.Path & "\NewDB.mdb.org", PathName & FileName
End If
End If
Exit Function
TestFileErr:
If Err = 75 Then Resume Next
End Function
Private Function GetDSN(sDSN As String, sDriver As String, sDBFile As String, lAction As Long) As Long
Dim sAttributes As String
Dim sDBQ As String
Dim lngRet As Long
Dim hKey As Long
Dim regValue As String
Dim valueType As Long
' query the Registry to check whether the DSN is already installed
' open the key
sDBQ = RegQuery(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" + sDSN, "DBQ")
If Left$(sDBQ, 11) = "No Such Key" Then
If Len(sDBFile) Then 'File path/name supplied
lngRet = MsgBox(sDBQ & vbCrLf & "CREATE IT?", vbYesNo)
If lngRet = vbYes Then
sDBQ = ""
Else
'Routine failed
GetDSN = False
Exit Function
End If
Else 'No file name supplied
GetDSN = False
Exit Function
End If
End If
If Len(sDBQ) Then 'DBQ found
If lAction = ODBC_ADD_SYS_DSN Or lAction = ODBC_ADD_DSN Then
'Verify file actually exists
If Len(Dir$(sDBFile)) Then
'Simply return DBQ
sDBFile = sDBQ
GetDSN = True
Exit Function
Else 'return error
GetDSN = False
Exit Function
End If
Else 'Delete it
sAttributes = "DSN=" & sDSN & vbNullChar & "DBQ=" & sDBFile & vbNullChar
lngRet = SQLConfigDataSource(0&, lAction, sDriver, sAttributes)
End If
Else 'Add it
' check that the file actually exists
If Len(sDBFile) > 0 And Len(Dir$(sDBFile)) Then 'create DSN
sAttributes = "DSN=" & sDSN & vbNullChar & "DBQ=" & sDBFile & vbNullChar
lngRet = SQLConfigDataSource(0&, lAction, sDriver, sAttributes)
Else 'Return with error
MsgBox "Database file doesn't exist!", vbOKOnly + vbCritical
GetDSN = False
Exit Function
End If
End If
If lngRet Then
GetDSN = True
Else
GetDSN = False
End If
End FunctionJ.A. Coutts