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

Erik A · Accepted Answer · 2018-08-07T13:55:11.160

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.

score 0 · Answer 2 · answered Aug 07 '18 at 14:20

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

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

2 Answers2