如何在 Access VBA 中设置对正在运行的对象的引用

Posted 2023-05-07

【中文标题】如何在 Access VBA 中设置对正在运行的对象的引用

【英文标题】：How to set a reference to a running object in Access VBA

【发布时间】：2018-08-07 11:50:09

【问题描述】：

我尝试使用 GetObject 在另一个数据库中打开一个表单。不幸的是，我必须打开数据库的第二个实例，但我想改用该数据库的活动实例（如果已加载）。为此，我需要为该数据库的运行实例设置一个对象引用。

我目前使用的是下面的功能。此函数首先尝试使用其屏幕名称激活正在运行的数据库实例，如果这产生错误，则加载数据库和表单。但是，如果数据库已经加载，我也希望能够加载表单。

较小的问题是如果加载数据库和表单的错误过程产生错误，则不遵循错误程序。我应该如何处理？

有人有想法吗？

我正在使用 Access 2016

谢谢。

彼得

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

【参考方案1】：

这不是一件容易的事，但可以通过使用一些 WinAPI 窗口函数来完成。

本质上，您希望通过使用窗口标题来获取 Access Application 对象。

我将假设您在该窗口标题中没有任何 unicode 字符，否则，我们需要一些更复杂的东西。

首先，声明我们的 WinAPI 函数：

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 用于查找具有指定标题的窗口。 AccessibleObjectFromWindow 用于获取该窗口的 COM 对象。

然后，我们声明一些用于 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

然后，我们就可以编写函数了

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

我不打算讨论链式错误处理程序的意义，但您可以查看this answer。请注意，重置错误处理程序也会重置 Err 对象，因此如果要使用它，您可能首先需要存储错误编号和描述。

【参考方案2】：

这就像一个魅力，非常感谢你！我自己从来没有想到过。

似乎在调整代码后也没有与嵌套错误相关的问题。我需要添加一个最大化调用，因为 mu 表单显示与屏幕相关，当其他数据库最小化时，这会导致一个不可见的表单。现在是最终代码

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

再次感谢您！

彼得