William Benson
vbacreations at gmail.com
Mon Dec 10 13:59:03 CST 2012
Thanks for the replies. I did think I needed to start Access if I could get
to the dbEngine object directly however I was looking for a reason as to
why, should I try to hook the DBEngine, I might not be able to. So I wanted
to be sure Access itself could be launched. Below my function which
follows, is some code from Wayne Phillips, I don't know what it is doing
but it digs into the registry to see which version of Access to launch via
a shell, I think. And it requires that there be a database path to try to
open. I am not sure why there is no way to just launch access and have it
sitting there in the background, without a database (Does
CreateObject doesn't usually require a target "document" but maybe
databases are different?)
Below, I make use of some code from Wayne Phillips to check if Access can
be launched. If it is not already. If it can be, I quit it, since it was me
who launched it. If it was already running, I'll know via GetObject.
Then after I have surety that Access can be launched, I try to use DBEngine.
If I can't then that must be due to reference issues which I am not skilled
enough to overcome as of now but I wanted to at least get to a diagnosis.
The machine I have, does have access, and I can't test this on a lot of
environments.
'My function
Public Function GetDB(strLoc As String) As Object
Dim Ac As Object
Dim GetDBEngine As Object
Dim strName As String
Dim bUseDBE As Boolean
On Error Resume Next
Set Ac = GetObject(, "Access.Application")
If Ac Is Nothing Then
Set Ac = CreateAccessInstance("Access.Application.15", strLoc)
If Ac Is Nothing Then
Set Ac = CreateAccessInstance("Access.Application.14", strLoc)
If Ac Is Nothing Then
Set Ac = CreateAccessInstance("Access.Application.12", strLoc)
If Ac Is Nothing Then
If UCase(Right(strLoc, 6)) = ".ACCDB" Then
'No sense trying to use DBEngine
Exit Function
End If
End If
End If
End If
If Not Ac Is Nothing Then
Debug.Print "We started Access, we can kill it"
Ac.Quit
bUseDBE = True
End If
Else
bUseDBE = True
End If
If bUseDBE Then
Err.Clear
Debug.Print "Trying to get the target through the DBEngine, and no
other db was open"
'try 120
Err.Clear
Set GetDBEngine = CreateObject("DAO.DBEngine.120")
If Err.Number <> 0 Then 'try 36
Err.Clear
Set GetDBEngine = CreateObject("DAO.DBEngine.36")
If Err.Number <> 0 Then
Set GetDBEngine = CreateObject("DAO.DBEngine.35")
End If
End If
If Not GetDBEngine Is Nothing Then
Set GetDB = GetDBEngine.Workspaces(0).OpenDatabase(strLoc)
End If
End If
If bUseDBE And GetDB Is Nothing Then
'Something is wrong - we can start and/or had an instance of Access but
'cannot hook the database engine
MsgBox "There is a problem with launching the database engine"
ElseIf Not bUseDBE Then
Err.Clear
Debug.Print "Trying to get the target through the DBEngine, and no
other db was open"
'try 120
Err.Clear
Set GetDBEngine = CreateObject("DAO.DBEngine.120")
If Err.Number <> 0 Then 'try 36
Err.Clear
Set GetDBEngine = CreateObject("DAO.DBEngine.36")
If Err.Number <> 0 Then
Set GetDBEngine = CreateObject("DAO.DBEngine.35")
End If
End If
If Not GetDBEngine Is Nothing Then
Set GetDB = GetDBEngine.Workspaces(0).OpenDatabase(strLoc)
End If
If GetDB Is Nothing Then
MsgBox "Cannot find Access on this machine nor do the libraries for
DAO appear to be installed or registered within this application."
End If
End If
End Function
Option Explicit
' ModCreateOfficeInstance by Wayne Phillips 2005 - © EverythingAccess.com
' Written on 23/11/2005 for automating a specific version of Access
' Updated on 07/03/2012 to allow for delayed binding and better error
handling.
Private Declare Function RegCloseKey Lib "advapi32" _
(ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32" _
Alias "RegOpenKeyA" _
(ByVal hKey As Long, _
ByVal sSubKey As String, _
hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal sKeyValue As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
nSizeData As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Function FnGetRegString(ByVal hKeyRoot As Long, _
ByVal strSubKey As String, _
ByVal strValueName As String, _
ByRef strRetVal As String) As Boolean
Dim lngDataSize As Long
Dim hKey As Long
Const ERROR_MORE_DATA = 234
Const ERROR_SUCCESS = 0
strRetVal = ""
If RegOpenKey(hKeyRoot, _
strSubKey, _
hKey) = ERROR_SUCCESS Then
'Calculate the length of string we need to initialize as a buffer...
If RegQueryValueEx(hKey, _
strValueName, _
0&, _
0&, _
ByVal strRetVal, _
lngDataSize) = ERROR_MORE_DATA Then
'Initialize the string buffer to a fixed length
strRetVal = String(lngDataSize + 1, 0)
If RegQueryValueEx(hKey, _
strValueName, _
0&, _
0&, _
ByVal strRetVal, _
lngDataSize) = ERROR_SUCCESS Then
'We got the value, trim the extra null terminator
strRetVal = Left(strRetVal, InStr(1, strRetVal, Chr(0)) - 1)
FnGetRegString = True
End If
End If
Call RegCloseKey(hKey)
End If
End Function
Private Function FnGetAssociatedPathFromProgID(ByVal strProgID As String)
As String
Dim strOutputPath As String
Const HKEY_CLASSES_ROOT = &H80000000
If FnGetRegString(HKEY_CLASSES_ROOT, strProgID & "\shell\Open\command",
"", strOutputPath) = True Then
FnGetAssociatedPathFromProgID = strOutputPath
End If
End Function
Public Function CreateOfficeInstance(ByVal strProgID As String, _
ByVal strFilePath) As Object
Dim strCommandLine As String
Dim strPath As String
'Get the class GUID (CLSID) from the input ProgID
strPath = FnGetAssociatedPathFromProgID(strProgID)
If Len(strPath) > 0 Then
'The returned path is actually a command line string with parameter
for file name as %1
strCommandLine = Replace(strPath, "%1", strFilePath)
Shell strCommandLine, vbMinimizedNoFocus
'Attempt to bind to the instance...
On Error GoTo RetryDelay
Set CreateOfficeInstance = GetObject(strFilePath).Application
Else
Err.Raise 76, , "CreateOfficeInstance: failed to get path
information for ProgID '" & strProgID & "'"
End If
Exit Function
RetryDelay:
' Binding to the created instance might fail if the external process
hasn't yet loaded the
' document / file and registered itself in the COM Running Object
Table, so we will retry
' several times after a short delay, before failing.
Dim RetryCount As Long
If RetryCount < 10 Then
Sleep 500 ' Wait half a second and try again (upto 10 times)
RetryCount = RetryCount + 1
Resume
Else
On Error GoTo 0
Err.Raise 429, , "CreateOfficeInstance: failed to bind to specific
instance of '" & strProgID & "'"
End If
End Function