Referencing all Running Instances Of Excel, Word and Access

[Jaafar Tribak]

Hi all,

This is a little Class which should allow for iterating over all running instances of excel, access and word in your computer. The GetAllApplicationsRefs Method gets you a COM reference to each and every instance of each application.

As we know, the vb GetObject function attaches to the instance that was created first so it is no good for getting a reference to other open instances if they have no document(s) open. I have seen issues reported with GetObject even when the instance has a document open within it ... This Class however, should overcome this problem because it works regardless of whether the application instances have open document(s) or not.

There is also the AccessibleObjectFromWindow api workaround, but that too necessitates at least one open document per application instance ... There is as well another approach which works by iterating the ROT (Running Object Table) but again, that too suffers from the same problem. (BTW, the vba code for iterating the ROT is quite interesting and such functionalty may come in handy. I will post the code here at some point, for future reference.)

I hope the code lives up to expectations. I have only tested it on my home pc, so I would love to get some feedback from other users in case they find any bugs or issues or if they have some suggestions.


File Download:
OfficeAppsRefs.xlsm



1- Class Code: C_OfficeAppsRefs

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function CoRegisterMessageFilter Lib "OLE32.DLL" (ByVal lFilterIn As Long, ByRef lPreviousFilter As Long) As Long
    Private Declare PtrSafe Function IIDFromString Lib "OLE32.DLL" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long
    Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, ByVal riid As LongPtr, ByVal wParam As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal Hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hUf As LongPtr, ByVal gaFlags As Long) As LongPtr
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal Hwnd As LongPtr, lpdwProcessId As Long) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal Hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function CoRegisterMessageFilter Lib "OLE32.DLL" (ByVal lFilterIn As Long, ByRef lPreviousFilter As Long) As Long
    Private Declare Function IIDFromString Lib "OLE32.DLL" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long
    Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, ByVal riid As LongPtr, ByVal wParam As LongPtr, ppvObject As Any) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal Hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare Function GetAncestor Lib "user32" (ByVal hUf As LongPtr, ByVal gaFlags As Long) As LongPtr
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal Hwnd As LongPtr, lpdwProcessId As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal Hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
#End If


' ________________________________________ PUBLIC METHOD _____________________________________________

Public Function GetAllApplicationsRefs() As Object
    Set GetAllApplicationsRefs = GetButtonsHwnds(GetDesktopWindow)
End Function



' ________________________________________ PRIVATE MEMBERS _____________________________________________

Private Function GetButtonsHwnds(ByVal Hwnd As LongPtr) As Object

'/// <summary>
    ' This recursive function searches the desktop for all "MsoCommandBar" windows(hwnd).
    ' Once the hwnd is found, it gets its Dispatch interface then
    ' navigates up to its parent application and stores the application COM reference
    ' along with its PID, in a late bound scripting *Dictionary* object.
  
    ' The function returns the references of all running instances of *Excel*, *Word* and *Access*.
  
    ' The Dictionary *Key* stores the PID of the application.
    ' The Dictionary *Value* stores the application COM ref or a descriptive string should an error occur.
  
    ' Advantage over other alternatives:
    ' ---------------------------------
    ' Unlike other approaches which make use of the AccessibleObjectFromWindow api or iterate the ROT,
    ' this function works when the applications don't have any documents open.
    ' Furthermore, the function should handle 3 office apps: Excel, Word and Access.
'/// <summary>


    Const GW_CHILD = 5&, GW_HWNDNEXT = 2&
    Const GA_ROOT = 2&, DBG_EXCEPTION_NOT_HANDLED = &H80010001

    Static oDict As Object
    Dim oDisp As Object
    Dim hAncestor As LongPtr, hChild As LongPtr
    Dim lPid As Long
    Dim lMsgFilter As Long
    Dim sAppName As String
    Dim sBuffer As String, lRet As Long
  
    If oDict Is Nothing Then
        Set oDict = CreateObject("Scripting.Dictionary")
    End If

    hChild = GetNextWindow(Hwnd, GW_CHILD)
    Do While hChild
        DoEvents  'DoEvents
        sBuffer = VBA.Space(256&)
        lRet = GetClassName(hChild, sBuffer, 256&)
        If VBA.Left(sBuffer, lRet) = "FullpageUIHost" Then
            GoTo BackStagePage_OnDisplay_Issue
        End If
        If VBA.Left(sBuffer, lRet) = "MsoCommandBar" Then
            hAncestor = GetAncestor(hChild, GA_ROOT)
            lRet = GetClassName(hAncestor, sBuffer, 256&)
            sAppName = VBA.Left(sBuffer, lRet)
            If sAppName = "XLMAIN" Or sAppName = "OpusApp" Or sAppName = "OMain" Then
                Select Case sAppName
                    Case Is = "XLMAIN"
                        sAppName = "Excel"
                    Case Is = "OpusApp"
                        sAppName = "Word"
                    Case Is = "OMain"
                        sAppName = "Access"
                End Select
                On Error Resume Next
                Call CoRegisterMessageFilter(0&, lMsgFilter)
                Set oDisp = HwndToDispatch(hChild)
                lPid = GetPid(hAncestor)
                If Not oDict.Exists(CStr(lPid)) Then
                    If Err.Number = DBG_EXCEPTION_NOT_HANDLED Then
                        Err.Clear
                        oDict.Add CStr(lPid), sAppName & " instance is hanging!"
                    Else
                        oDict.Add CStr(lPid), oDisp.Application
                    End If
BackStagePage_OnDisplay_Issue:
                        hAncestor = GetAncestor(hChild, GA_ROOT)
                        lPid = GetPid(hAncestor)
                        oDict.Add CStr(lPid), "Error! Unable to get a COM pointer." & vbCrLf & _
                        Space(17&) & "The application is not responding." & vbCrLf & _
                        Space(17&) & "It may be in Edit mode or" & vbCrLf & _
                        Space(17&) & "it may be displaying a modal DialogBox or a BackStagePage! (FullpageUIHost)"
                        GoTo Nxt
                End If
            End If
Nxt:
            If Err.Number = DBG_EXCEPTION_NOT_HANDLED Then
                Call CoRegisterMessageFilter(lMsgFilter, lMsgFilter)
            End If
        End If
        sBuffer = ""
        Call GetButtonsHwnds(hChild)
        hChild = GetNextWindow(hChild, GW_HWNDNEXT)
    Loop
  
    Set GetButtonsHwnds = oDict

End Function

Private Function GetPid(ByVal Hwnd As LongPtr) As Long
    Call GetWindowThreadProcessId(Hwnd, GetPid)
End Function

Private Function HwndToDispatch(ByVal Hwnd As LongPtr) As Object

    #If Win64 Then
        Const NULL_PTR = 0^
    #Else
        Const NULL_PTR = 0&
    #End If
    Const WM_GETOBJECT = &H3D&, OBJID_CLIENT = &HFFFFFFFC, S_OK = 0&
    Const IID_IDISPATCH = "{00020400-0000-0000-C000-000000000046}"
    Dim oDisp As Object
    Dim hClient As LongPtr, lResult As Long
    Dim tGUID(0& To 3&) As Long
  
    lResult = SendMessage(Hwnd, WM_GETOBJECT, NULL_PTR, ByVal OBJID_CLIENT)
    If lResult Then
        If IIDFromString(StrPtr(IID_IDISPATCH), VarPtr(tGUID(0&))) = S_OK Then
            If ObjectFromLresult(lResult, VarPtr(tGUID(0&)), NULL_PTR, oDisp) = S_OK Then
                If Not oDisp Is Nothing Then
                    Set HwndToDispatch = oDisp
                End If
            End If
        End If
    End If
  
End Function

2- Usage Example :

Option Explicit


Sub Test()
    'Retrieve the references of all running instances of Excel, Word and Access
    'and prints the applications names and PID in the immediate window.

    Dim oRefs As New C_OfficeAppsRefs
    Dim oApps As Object  '<== Late bound Scripting.Dictionary object holder.
    Dim oApp As Variant
    Dim sOutput As String, lCount As Long
  
    ' The Dictionary *Key* stores the PID of the application.
    ' The Dictionary *Value* stores the application COM ref or a descriptive string should an error occur.
  
    Set oApps = oRefs.GetAllApplicationsRefs

    If Not oApps Is Nothing Then
        sOutput = "Total Office Applications found: [" & oApps.Count & "]" & vbCrLf
        sOutput = sOutput & "====================================" & vbCrLf
        Debug.Print sOutput
        For Each oApp In oApps
            If IsObject(oApps(oApp)) Then
                sOutput = "[App Name:]   " & oApps(oApp).Name
            Else
                sOutput = "[App Name:]   " & oApps(oApp)
            End If
            lCount = lCount + 1
            Debug.Print lCount & "- "; sOutput, Tab(0), "    (PID:) " & oApp
            Debug.Print "------------------------------------"
        Next oApp
    End If
    Debug.Print
  
End Sub

 

[Jaafar Tribak]

Hi Jaafar. Trialed your VBA code on office 21 with a 64 bit install and it works great! It seems some instructions would be helpful so I'll outline what I did for the trial. Create a userform (Userform1). Add 2 large listboxes and rename them lbxMonikers & lbxMonikerInfo. Add 2 command buttons and rename them btnUpdate & btnClose. I used an activeX command button with "UserForm1.Show" code. However, the listboxes don't load until the userform gets some focus so I added this bit of userform code and it all works well...

Private Sub UserForm_Activate()
UserForm1.btnUpdate.SetFocus
End Sub

Thanks for sharing your efforts Jaafar. Dave

Thanks NdNoviceHlp for testing and providing feedback.

 

[Jaafar Tribak]

Works perfectly for me - Windows 11 - MS365 - 64bit.

Thanks Dan_W for testing.

I will note (and I don't know if this is significant or intended) that the EXE program and your program above, came up with a different number of items.

I get exactly the same number of items when compared to IROTVIEW.exe and AlaxRotView-Win32.exe (see attached image). This is in Win10 x64bit Office 2016 x64bit.

Regarding the moniker info details (in the bottom Listbox), I skipped the *Reduced* and *Enumerated* fields and added my own *Object Type*, *ProgID* and *COM Pointer* fields which I deemed to be quite useful info.