How to set a reference to a running object in Access VBA

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.