Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,775
Office Version
  1. 2016
Platform
  1. 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
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 Function



2- 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:
But in Recent backstageview there is no a Back push button.
View attachment 118613
In that case, I won't be able to help I am afraid, as I have only Excel 2016 which provides the "back" button in the backstageview.

BTW, regarding your previous question about finding excel instances when the Ribbon is hidden , I do have written some new code which doesn't rely on the Ribbon at all and hence it should now work.

I will be posting the code later on as I am having some difficulties with my internet connection at the moment.

Stay tuned.
 
Upvote 0

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
But in Recent backstageview there is no a Back push button.
View attachment 118613
Yes there is (as below), but you have to have a workbook loaded in order for it to display. The only time I can see that it does not display is when you have loaded a new instance of Excel. At which point there is nowhere to go 'back' to.

1730082677092.png
 
Upvote 0
Hi Jaafar, your code can not return those Excel instances which both Ribbon and Status Bar are hidden:
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"", ""False"")"
Application.DisplayStatusBar = False
Will you consider to use IAccessible instead of IDispatch?

File Demo:
ExcelAppsCollection.xlsm

Here is the new code which should work regardless of whether the Ribbon is visisble or not because it obtains the Dispatch interface of the "Worksheet Menu Bar" via the OBJID_MENU AccessibleObjectID and from there up to the Application Parent object.

1- In a Standard Module:
VBA Code:
Option Explicit
Option Base 1

#If Win64 Then
    Private Const PTR_SIZE = 8&, NULL_PTR = 0^
#Else
    Private Const PTR_SIZE = 4&, NULL_PTR = 0&
#End If
Private Const SIZE = PTR_SIZE * 1.5

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function ArrPtr Lib "VBE7" Alias "VarPtr" (var() As Any) As LongLong
    #Else
        Private Declare PtrSafe Function ArrPtr Lib "VBE7" Alias "VarPtr" (var() As Any) As Long
    #End If
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    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
    Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByRef lParam As LongPtr) As Long
    Private Declare PtrSafe Function SafeArrayAccessData Lib "oleaut32" Alias "#23" (ByVal pSA As LongPtr, pData As LongPtr) As Long
    Private Declare PtrSafe Function SafeArrayUnaccessData Lib "oleaut32" Alias "#24" (ByVal pSA As LongPtr) As Long
    Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32" Alias "#17" (ByVal pSA As LongPtr) As Long
    Private Declare PtrSafe Function SafeArrayGetElemsize Lib "oleaut32" Alias "#18" (ByVal pSA As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function ArrPtr Lib "VBE6" Alias "VarPtr" (var() As Any) As Long
    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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    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
    Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByRef lParam As LongPtr) As Long
    Private Declare Function SafeArrayAccessData Lib "oleaut32" Alias "#23" (ByVal pSA As LongPtr, pData As LongPtr) As Long
    Private Declare Function SafeArrayUnaccessData Lib "oleaut32" Alias "#24" (ByVal pSA As LongPtr) As Long
    Private Declare Function SafeArrayGetDim Lib "oleaut32" Alias "#17" (ByVal pSA As LongPtr) As Long
    Private Declare Function SafeArrayGetElemsize Lib "oleaut32" Alias "#18" (ByVal pSA As LongPtr) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
#End If
    
Public Type INSTANCE_INFO
    Dispatch As Object
    PID As Long
    hwnd As LongPtr
    ModuleHandle As LongPtr
    DocCount As Long
    Visible As Boolean
    IsHungAppWindow As Boolean
    TotalInstances As Long
End Type

Private arInfo() As INSTANCE_INFO


Public Function GetAllExcelInstances() As INSTANCE_INFO()
    Dim pInfo As LongPtr
    Call EnumWindows(AddressOf EnumProc, pInfo)
    If pInfo Then
        GetAllExcelInstances = SafeArrPtr_To_BytesArray(pInfo)
    End If
    If Not (Not arInfo) Then
        Call CleanUpMemory(arInfo)
        Erase arInfo
    End If
End Function

Private Function SafeArrPtr_To_BytesArray(ByRef pArr As LongPtr) As INSTANCE_INFO()

    #If Win64 Then
    Const OFFSET = 3& * PTR_SIZE
    #Else
    Const OFFSET = 4& * PTR_SIZE
    #End If
    Dim pData As LongPtr
    Dim lDimCount As Long, lElemSize As Long, lTotalElems As Long
    Dim lElemsInDim As Long, lDataSize As Long
    Dim lOffset, n As Long
    
    lDimCount = SafeArrayGetDim(pArr)
    lElemSize = SafeArrayGetElemsize(pArr)
    lTotalElems = 1&
    For n = 0& To lDimCount - 1&
        Call CopyMemory(lElemsInDim, ByVal pArr + OFFSET + n * (PTR_SIZE * 2&), PTR_SIZE)
        lTotalElems = lTotalElems * lElemsInDim
    Next n
    lDataSize = (lTotalElems * lElemSize)
    ReDim Bytes(lDataSize - 1&) As INSTANCE_INFO
    Call SafeArrayAccessData(pArr, pData)
    Call CopyMemory(ByVal VarPtr(Bytes(1&)), ByVal pData, lDataSize)
    Call CopyMemory(pData, 0&, PTR_SIZE)
    Call SafeArrayUnaccessData(pArr)
    Call CopyMemory(pArr, 0&, PTR_SIZE)
    SafeArrPtr_To_BytesArray = Bytes()
    Erase Bytes

End Function

Private Function EnumProc(ByVal hwnd As LongPtr, ByRef lParam As LongPtr) As Long

    Const WM_ACTIVATEAPP = &H1C, DBG_EXCEPTION_NOT_HANDLED = &H80010001
    Static lXlCnt As Long
    Dim tInfo As INSTANCE_INFO
    Dim oDisp As Object
    Dim sClassName As String * 256, lRet As Long
    Dim lMsgFilter As Long, i As Long

    If (Not (Not arInfo)) = False Then
        lXlCnt = 0&
    End If
    On Error Resume Next
    lRet = GetClassName(hwnd, sClassName, 256)
    Call CoRegisterMessageFilter(lMsgFilter, lMsgFilter)
    If Left(sClassName, lRet) = "XLMAIN" Then
        If IsGhostWnd(hwnd) Then GoTo SkipXlGhostWnd
        Call SendMessage(hwnd, WM_ACTIVATEAPP, True, ByVal 0&)
        Set oDisp = Hwnd_To_Menu_Dispatch(hwnd)
        Call SendMessage(Application.hwnd, WM_ACTIVATEAPP, True, ByVal 0&)
        With tInfo
            Call GetWindowThreadProcessId(hwnd, .PID)
            .hwnd = hwnd
            .ModuleHandle = GetModuleHandle(vbNullString)
            .Visible = IsWindowVisible(hwnd)
            If Not oDisp Is Nothing Then
                Set .Dispatch = oDisp.Parent
                If Err.Number = DBG_EXCEPTION_NOT_HANDLED Then
                    .DocCount = -1&
                Else
                    .DocCount = oDisp.Parent.Workbooks.Count
                End If
                .IsHungAppWindow = IIf(Err.Number = DBG_EXCEPTION_NOT_HANDLED, True, False)
            Else
                Set .Dispatch = Nothing
                .DocCount = -1&
                .Visible = True
                .IsHungAppWindow = True
            End If
            lXlCnt = lXlCnt + 1&
            ReDim Preserve arInfo(lXlCnt)
            For i = LBound(arInfo) To UBound(arInfo)
                arInfo(i).TotalInstances = UBound(arInfo)
            Next i
            .TotalInstances = lXlCnt
            arInfo(lXlCnt) = tInfo
            If lParam = NULL_PTR Then
                Call CopyMemory(lParam, ByVal ArrPtr(arInfo), PTR_SIZE)
            End If
        End With
    End If
SkipXlGhostWnd:
    Call CoRegisterMessageFilter(0&, lMsgFilter)
    EnumProc = 1&
  
End Function

Private Function Hwnd_To_Menu_Dispatch(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_MENU = -3&, 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_MENU)
    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 Hwnd_To_Menu_Dispatch = oDisp
                End If
            End If
        End If
    End If

End Function

Private Function IsGhostWnd(ByVal hwnd As LongPtr) As Boolean
    Static oColl As Collection
    Dim lPid As Long
    If (Not (Not arInfo)) = False Then Set oColl = New Collection
    Call GetWindowThreadProcessId(hwnd, lPid)
    On Error Resume Next
        oColl.Add hwnd, CStr(lPid)
        IsGhostWnd = (Err.Number <> 0&)
    Err.Clear
End Function

Private Sub CleanUpMemory(ByRef tInfo() As INSTANCE_INFO)
    Dim n As Long
    For n = LBound(tInfo) To UBound(tInfo)
        CopyMemory tInfo(n).Dispatch, 0&, PTR_SIZE
    Next n
    Erase tInfo
End Sub

Private Sub Auto_Close()
    If Not (Not arInfo) Then
        Call CleanUpMemory(arInfo)
        Erase arInfo
    End If
End Sub


2- Code Usage Example:
VBA Code:
Option Explicit

Sub Test()
    Dim Excel_Instances() As INSTANCE_INFO
    Dim Total_Excel_Instances As Long
    Dim Instance As Long
    Dim Headings As Variant, lRw As Long

    Excel_Instances = GetAllExcelInstances
    Total_Excel_Instances = Excel_Instances(LBound(Excel_Instances)).TotalInstances
    'Prepare table headings.
    Headings = Array("Instance #", "Responding", "Dispatch Pointer", "PID", "HWND", _
    "Module Handle", "Workbooks count", "Visible", "ToTal Excel Instances")
    With Sheet1
    .Cells.ClearContents
        With .Cells(4, 1).Resize(1, 9)
            .Value = Headings
            .Font.Bold = 0
            .Font.Color = vbRed
            .Interior.Color = 13224393
            .Resize(Total_Excel_Instances + 1&, 9).HorizontalAlignment = xlCenter
            .Resize(Total_Excel_Instances + 1&, 9).NumberFormat = "@"
            'Populate table with instances info.
            For Instance = 1& To Total_Excel_Instances
                lRw = Instance + 1
                .Cells(lRw, 1) = Instance
                .Cells(lRw, 2) = Not Excel_Instances(Instance).IsHungAppWindow
                .Cells(lRw, 3) = IIf(Excel_Instances(Instance).IsHungAppWindow, "??", CStr(ObjPtr(Excel_Instances(Instance).Dispatch)))
                .Cells(lRw, 4) = Excel_Instances(Instance).PID
                .Cells(lRw, 5) = Excel_Instances(Instance).hwnd
                .Cells(lRw, 6) = CStr(Excel_Instances(Instance).ModuleHandle)
                .Cells(lRw, 7) = IIf(Excel_Instances(Instance).IsHungAppWindow, "??", Excel_Instances(Instance).DocCount)
                .Cells(lRw, 8) = Excel_Instances(Instance).Visible
                .Cells(lRw, 9) = Excel_Instances(Instance).TotalInstances
            Next Instance
        End With
        .Cells.EntireColumn.AutoFit
    End With

    'Debug.Print
    'Debug.Print "==================================="
    'Debug.Print vbTab & "Total Excel Instances:"; "[" & Excel_Instances(1).TotalInstances & "]"
    'Debug.Print "==================================="
    'For Instance = 1 To Excel_Instances(1).TotalInstances
    '    Debug.Print "*Instance #"; "[" & Instance & "]"
    '    Debug.Print vbTab & "- Dispatch Ptr: "; IIf(ObjPtr(Excel_Instances(Instance).Dispatch) = 0, "??", ObjPtr(Excel_Instances(Instance).Dispatch))
    '    Debug.Print vbTab & "- PID: "; Excel_Instances(Instance).PID
    '    Debug.Print vbTab & "- HWND: "; Excel_Instances(Instance).hwnd
    '    Debug.Print vbTab & "- ModuleHandle: "; Excel_Instances(Instance).ModuleHandle
    '    Debug.Print vbTab & "- Workbooks Count: "; IIf(ObjPtr(Excel_Instances(Instance).Dispatch) = 0, "??", Excel_Instances(Instance).DocCount)
    '    Debug.Print vbTab & "- Visible: "; Excel_Instances(Instance).Visible
    '    Debug.Print vbTab & "- Responding: "; Not Excel_Instances(Instance).IsHungAppWindow
    '    Debug.Print vbTab & "- ToTal Xl Instances: "; Excel_Instances(Instance).TotalInstances
    '    Debug.Print vbTab & "---------------------------"
    'Next
End Sub

Sub Excel_Instances_Factory()
    Dim xlapp As Object
    Set xlapp = CreateObject("Excel.Application")
    xlapp.Visible = True
    xlapp.Workbooks.Add
End Sub
 
Upvote 0
Regarding the ability to close the backstageview window , I think it should be better to find the correct window messages and use SendMessage API instead of using Accessibility. This is because the backstageview has a HWND.

I have been experiencing landline internet connection problems in the last few days so I will hopefully look into this later.
 
Upvote 0
File Demo:
ExcelAppsCollection.xlsm

Here is the new code which should work regardless of whether the Ribbon is visisble or not because it obtains the Dispatch interface of the "Worksheet Menu Bar" via the OBJID_MENU AccessibleObjectID and from there up to the Application Parent object.

1- In a Standard Module:
VBA Code:
Option Explicit
Option Base 1

#If Win64 Then
    Private Const PTR_SIZE = 8&, NULL_PTR = 0^
#Else
    Private Const PTR_SIZE = 4&, NULL_PTR = 0&
#End If
Private Const SIZE = PTR_SIZE * 1.5

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function ArrPtr Lib "VBE7" Alias "VarPtr" (var() As Any) As LongLong
    #Else
        Private Declare PtrSafe Function ArrPtr Lib "VBE7" Alias "VarPtr" (var() As Any) As Long
    #End If
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    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
    Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByRef lParam As LongPtr) As Long
    Private Declare PtrSafe Function SafeArrayAccessData Lib "oleaut32" Alias "#23" (ByVal pSA As LongPtr, pData As LongPtr) As Long
    Private Declare PtrSafe Function SafeArrayUnaccessData Lib "oleaut32" Alias "#24" (ByVal pSA As LongPtr) As Long
    Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32" Alias "#17" (ByVal pSA As LongPtr) As Long
    Private Declare PtrSafe Function SafeArrayGetElemsize Lib "oleaut32" Alias "#18" (ByVal pSA As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function ArrPtr Lib "VBE6" Alias "VarPtr" (var() As Any) As Long
    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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    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
    Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByRef lParam As LongPtr) As Long
    Private Declare Function SafeArrayAccessData Lib "oleaut32" Alias "#23" (ByVal pSA As LongPtr, pData As LongPtr) As Long
    Private Declare Function SafeArrayUnaccessData Lib "oleaut32" Alias "#24" (ByVal pSA As LongPtr) As Long
    Private Declare Function SafeArrayGetDim Lib "oleaut32" Alias "#17" (ByVal pSA As LongPtr) As Long
    Private Declare Function SafeArrayGetElemsize Lib "oleaut32" Alias "#18" (ByVal pSA As LongPtr) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
#End If
   
Public Type INSTANCE_INFO
    Dispatch As Object
    PID As Long
    hwnd As LongPtr
    ModuleHandle As LongPtr
    DocCount As Long
    Visible As Boolean
    IsHungAppWindow As Boolean
    TotalInstances As Long
End Type

Private arInfo() As INSTANCE_INFO


Public Function GetAllExcelInstances() As INSTANCE_INFO()
    Dim pInfo As LongPtr
    Call EnumWindows(AddressOf EnumProc, pInfo)
    If pInfo Then
        GetAllExcelInstances = SafeArrPtr_To_BytesArray(pInfo)
    End If
    If Not (Not arInfo) Then
        Call CleanUpMemory(arInfo)
        Erase arInfo
    End If
End Function

Private Function SafeArrPtr_To_BytesArray(ByRef pArr As LongPtr) As INSTANCE_INFO()

    #If Win64 Then
    Const OFFSET = 3& * PTR_SIZE
    #Else
    Const OFFSET = 4& * PTR_SIZE
    #End If
    Dim pData As LongPtr
    Dim lDimCount As Long, lElemSize As Long, lTotalElems As Long
    Dim lElemsInDim As Long, lDataSize As Long
    Dim lOffset, n As Long
   
    lDimCount = SafeArrayGetDim(pArr)
    lElemSize = SafeArrayGetElemsize(pArr)
    lTotalElems = 1&
    For n = 0& To lDimCount - 1&
        Call CopyMemory(lElemsInDim, ByVal pArr + OFFSET + n * (PTR_SIZE * 2&), PTR_SIZE)
        lTotalElems = lTotalElems * lElemsInDim
    Next n
    lDataSize = (lTotalElems * lElemSize)
    ReDim Bytes(lDataSize - 1&) As INSTANCE_INFO
    Call SafeArrayAccessData(pArr, pData)
    Call CopyMemory(ByVal VarPtr(Bytes(1&)), ByVal pData, lDataSize)
    Call CopyMemory(pData, 0&, PTR_SIZE)
    Call SafeArrayUnaccessData(pArr)
    Call CopyMemory(pArr, 0&, PTR_SIZE)
    SafeArrPtr_To_BytesArray = Bytes()
    Erase Bytes

End Function

Private Function EnumProc(ByVal hwnd As LongPtr, ByRef lParam As LongPtr) As Long

    Const WM_ACTIVATEAPP = &H1C, DBG_EXCEPTION_NOT_HANDLED = &H80010001
    Static lXlCnt As Long
    Dim tInfo As INSTANCE_INFO
    Dim oDisp As Object
    Dim sClassName As String * 256, lRet As Long
    Dim lMsgFilter As Long, i As Long

    If (Not (Not arInfo)) = False Then
        lXlCnt = 0&
    End If
    On Error Resume Next
    lRet = GetClassName(hwnd, sClassName, 256)
    Call CoRegisterMessageFilter(lMsgFilter, lMsgFilter)
    If Left(sClassName, lRet) = "XLMAIN" Then
        If IsGhostWnd(hwnd) Then GoTo SkipXlGhostWnd
        Call SendMessage(hwnd, WM_ACTIVATEAPP, True, ByVal 0&)
        Set oDisp = Hwnd_To_Menu_Dispatch(hwnd)
        Call SendMessage(Application.hwnd, WM_ACTIVATEAPP, True, ByVal 0&)
        With tInfo
            Call GetWindowThreadProcessId(hwnd, .PID)
            .hwnd = hwnd
            .ModuleHandle = GetModuleHandle(vbNullString)
            .Visible = IsWindowVisible(hwnd)
            If Not oDisp Is Nothing Then
                Set .Dispatch = oDisp.Parent
                If Err.Number = DBG_EXCEPTION_NOT_HANDLED Then
                    .DocCount = -1&
                Else
                    .DocCount = oDisp.Parent.Workbooks.Count
                End If
                .IsHungAppWindow = IIf(Err.Number = DBG_EXCEPTION_NOT_HANDLED, True, False)
            Else
                Set .Dispatch = Nothing
                .DocCount = -1&
                .Visible = True
                .IsHungAppWindow = True
            End If
            lXlCnt = lXlCnt + 1&
            ReDim Preserve arInfo(lXlCnt)
            For i = LBound(arInfo) To UBound(arInfo)
                arInfo(i).TotalInstances = UBound(arInfo)
            Next i
            .TotalInstances = lXlCnt
            arInfo(lXlCnt) = tInfo
            If lParam = NULL_PTR Then
                Call CopyMemory(lParam, ByVal ArrPtr(arInfo), PTR_SIZE)
            End If
        End With
    End If
SkipXlGhostWnd:
    Call CoRegisterMessageFilter(0&, lMsgFilter)
    EnumProc = 1&
 
End Function

Private Function Hwnd_To_Menu_Dispatch(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_MENU = -3&, 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_MENU)
    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 Hwnd_To_Menu_Dispatch = oDisp
                End If
            End If
        End If
    End If

End Function

Private Function IsGhostWnd(ByVal hwnd As LongPtr) As Boolean
    Static oColl As Collection
    Dim lPid As Long
    If (Not (Not arInfo)) = False Then Set oColl = New Collection
    Call GetWindowThreadProcessId(hwnd, lPid)
    On Error Resume Next
        oColl.Add hwnd, CStr(lPid)
        IsGhostWnd = (Err.Number <> 0&)
    Err.Clear
End Function

Private Sub CleanUpMemory(ByRef tInfo() As INSTANCE_INFO)
    Dim n As Long
    For n = LBound(tInfo) To UBound(tInfo)
        CopyMemory tInfo(n).Dispatch, 0&, PTR_SIZE
    Next n
    Erase tInfo
End Sub

Private Sub Auto_Close()
    If Not (Not arInfo) Then
        Call CleanUpMemory(arInfo)
        Erase arInfo
    End If
End Sub


2- Code Usage Example:
VBA Code:
Option Explicit

Sub Test()
    Dim Excel_Instances() As INSTANCE_INFO
    Dim Total_Excel_Instances As Long
    Dim Instance As Long
    Dim Headings As Variant, lRw As Long

    Excel_Instances = GetAllExcelInstances
    Total_Excel_Instances = Excel_Instances(LBound(Excel_Instances)).TotalInstances
    'Prepare table headings.
    Headings = Array("Instance #", "Responding", "Dispatch Pointer", "PID", "HWND", _
    "Module Handle", "Workbooks count", "Visible", "ToTal Excel Instances")
    With Sheet1
    .Cells.ClearContents
        With .Cells(4, 1).Resize(1, 9)
            .Value = Headings
            .Font.Bold = 0
            .Font.Color = vbRed
            .Interior.Color = 13224393
            .Resize(Total_Excel_Instances + 1&, 9).HorizontalAlignment = xlCenter
            .Resize(Total_Excel_Instances + 1&, 9).NumberFormat = "@"
            'Populate table with instances info.
            For Instance = 1& To Total_Excel_Instances
                lRw = Instance + 1
                .Cells(lRw, 1) = Instance
                .Cells(lRw, 2) = Not Excel_Instances(Instance).IsHungAppWindow
                .Cells(lRw, 3) = IIf(Excel_Instances(Instance).IsHungAppWindow, "??", CStr(ObjPtr(Excel_Instances(Instance).Dispatch)))
                .Cells(lRw, 4) = Excel_Instances(Instance).PID
                .Cells(lRw, 5) = Excel_Instances(Instance).hwnd
                .Cells(lRw, 6) = CStr(Excel_Instances(Instance).ModuleHandle)
                .Cells(lRw, 7) = IIf(Excel_Instances(Instance).IsHungAppWindow, "??", Excel_Instances(Instance).DocCount)
                .Cells(lRw, 8) = Excel_Instances(Instance).Visible
                .Cells(lRw, 9) = Excel_Instances(Instance).TotalInstances
            Next Instance
        End With
        .Cells.EntireColumn.AutoFit
    End With

    'Debug.Print
    'Debug.Print "==================================="
    'Debug.Print vbTab & "Total Excel Instances:"; "[" & Excel_Instances(1).TotalInstances & "]"
    'Debug.Print "==================================="
    'For Instance = 1 To Excel_Instances(1).TotalInstances
    '    Debug.Print "*Instance #"; "[" & Instance & "]"
    '    Debug.Print vbTab & "- Dispatch Ptr: "; IIf(ObjPtr(Excel_Instances(Instance).Dispatch) = 0, "??", ObjPtr(Excel_Instances(Instance).Dispatch))
    '    Debug.Print vbTab & "- PID: "; Excel_Instances(Instance).PID
    '    Debug.Print vbTab & "- HWND: "; Excel_Instances(Instance).hwnd
    '    Debug.Print vbTab & "- ModuleHandle: "; Excel_Instances(Instance).ModuleHandle
    '    Debug.Print vbTab & "- Workbooks Count: "; IIf(ObjPtr(Excel_Instances(Instance).Dispatch) = 0, "??", Excel_Instances(Instance).DocCount)
    '    Debug.Print vbTab & "- Visible: "; Excel_Instances(Instance).Visible
    '    Debug.Print vbTab & "- Responding: "; Not Excel_Instances(Instance).IsHungAppWindow
    '    Debug.Print vbTab & "- ToTal Xl Instances: "; Excel_Instances(Instance).TotalInstances
    '    Debug.Print vbTab & "---------------------------"
    'Next
End Sub

Sub Excel_Instances_Factory()
    Dim xlapp As Object
    Set xlapp = CreateObject("Excel.Application")
    xlapp.Visible = True
    xlapp.Workbooks.Add
End Sub
If I click the menu File in a workbook to show the File Tab backstageview, running your new code can't get this instance.
ScreenHunter 1958.jpg

But it can be retrieved by using AccessibleObjectFromWindow from hwnd XLMAIN->XLDESK->EXCEL7.
 
Upvote 0
If I click the menu File in a workbook to show the File Tab backstageview, running your new code can't get this instance.
View attachment 118660
But it can be retrieved by using AccessibleObjectFromWindow from hwnd XLMAIN->XLDESK->EXCEL7.
Well I guess the AccessibleObjectFromWindow can be incorporated to the last code when the backstageview is open.

The problem with getting dispatch pointers to the running excel instances is that the excel instance must be responsive ... Excel doesn't respond to com calls when it is hung up such as when it is in Edit Mode or when a modal dialog is on display ... So, solving the backstageview issue will not entirely solve the issue of excel not responding to com calls.

The only thing I can think of is to have code loop through each excel HWND and check if the excel instance is in any of the above situations (ie: If it is in edit mode, has a modal dialog on display or if the backstageview is active) and if so, have some code to get the excel instance out of that non- responsive situation and then move on to the next excel instance.

In theory, this can be done but will not be easy.
 
Upvote 0
Also, it seems that the minimized instance cannot be retrieved.
True. I didn't expect that ! These special situations, although not frequent , can spoil everything.

If I get the time, I will see if with vba, one can take excel instances out of those 4 states ( Edit Mode, owned modal dialog on display, BackstageView and now minimized state) before making the com calls.
 
Upvote 0
@onkey
Hi,

This is an update of the code which takes into account the following excel specific states :

1- Excel Window is Minimized.
2- Excel is Hidden.
3- Excel is in Edit Mode
4- BaackstgaeView on display.
5- Modal/Modeless Userform(s) on display.
6- Msgbox(s)\InputBox(s) on display.
7- Owned and UnOwned Excel Dialog(s) on display.

Basically, the code loops through each excel applicaion instances and if it finds one that is not responding due to any of the aboves mentioned states, it takes it out of that state (except the visibility state) before performing the com call to get a pointer to the application Dispatch Interface.

File Demo:
ExcelAppsCollection_V2.xlsm

Please, download the workbook demo from the above link and try the code. See how it goes and let me know ... If everything is ok, I will post the entire code here for future reference.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,114
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top