How to set a reference to a running object in Access VBA - ms-access

Question

I try to open a form in another database by using GetObject. Unfortunately I have to open a second instance of the database, but I would like to use the active instance of that database instead (if loaded). TO accomplish this I need to set an object reference to the running instance of that db.
What I currently use is the function below. This function first tries to activate the running instance of the database using its screen name, and if this generates an error the database and the form are loaded. However, if the database is already loaded I want to be able to load the form as well.
On lesser problem is if the error procedure to load the db and form generates an error, the error routine is not followed. How should I manage that?
Anyone has an idea?
I'm Using Access 2016
Thx.
Peter
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
'Activate DB if open
AppActivate strAppName
AppDbOpen = True
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case 5 'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
AppDbOpen = True
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_GeneralFunctions" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function

Answer 1

This is not an easy task, but it can be accomplished by using some WinAPI window functions.
Essentially, you want to get an Access Application object by using the window title.
I'm going to assume you haven't got any unicode characters in that window title, else, we'll need something a little more complex.
First, declare our WinAPI functions:
Declare PtrSafe Function FindWindowExA Lib "user32" (Optional ByVal hWndParent As LongPtr, Optional ByVal hwndChildAfter As LongPtr, Optional ByVal lpszClass As String, Optional ByVal lpszWindow As String) As LongPtr
Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
FindWindowExA is used to find the window with the specified title. AccessibleObjectFromWindow is used to get the COM object of that window.
Then, we declare some constants to be used for AccessibleObjectFromWindow:
Const strIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" 'To identify the IDISPATCH COM interface
Const OBJID_NATIVEOM As Long = &HFFFFFFF0 'To identify the object type
Then, we can write the function
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
'Activate DB if open
AppActivate strAppName
AppDbOpen = True
Dim hwndAppDb As LongPtr
hwndAppDb = FindWindowExA (,,,strAppName) 'Find the window handle (hWnd)
If hwndAppDb <> 0 Then 'If it's 0, something went wrong, check the title
Dim guid() As Byte
guid = Application.GuidFromString(strIID_IDispatch)
'Get the IDispatch object associated with that handle
AccessibleObjectFromWindow hwndAppDb, OBJID_NATIVEOM, guid(0), objDb
End If
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case 5 'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
AppDbOpen = True
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_GeneralFunctions" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
I'm not going to discuss the point of chained error handlers, but you can just review this answer for that. Note that resetting the error handler resets the Err object as well, so you might first want to store error number and description if you want to use that.

Answer 2

This worked like a charm, thank you so much! I never figured this out by myself.
It seems that after an adjustment of the code there is no issue related to the nested errors too. I needed to add a maximize call because mu forms are showed related to the screen and this causes an invisible form when the other database was minimized. The final code is now
Option Compare Database
Option Explicit
Declare PtrSafe Function FindWindowExA Lib "user32" (Optional ByVal hWndParent As LongPtr, _
Optional ByVal hwndChildAfter As LongPtr, Optional ByVal lpszClass As String, _
Optional ByVal lpszWindow As String) As LongPtr
Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, _
ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Const strIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" 'To identify the IDISPATCH COM interface
Const OBJID_NATIVEOM = &HFFFFFFF0 'To identify the object type
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
Dim hwndAppDb As LongPtr
'Find the Db handle
hwndAppDb = FindWindowExA(, , , strAppName) 'Find the window handle (hWnd)
If hwndAppDb <> 0 Then 'If it's 0, something went wrong, check the title
'Activate DB if open
Dim guid() As Byte
guid = Application.GUIDFromString(strIID_IDispatch)
'Get the IDispatch object associated with that handle
AccessibleObjectFromWindow hwndAppDb, OBJID_NATIVEOM, guid(0), objDb
Else
'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
End If
If Nz(strOpenForm, "") <> "" Then
objDb.RunCommand acCmdAppMaximize
objDb.DoCmd.OpenForm strOpenForm
objDb.Run "CenterForm", strOpenForm, False, False, False, 0
End If
AppDbOpen = True
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_OpenExtDb" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
Again, thank you!
Peter