Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
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
2- Usage Example :
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
VBA Code:
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 Function2- Usage Example :
VBA Code:
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
Last edited:
