Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,806
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:

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
This is great - thank you. I'll add it to my education.
Though, I'm pretty happy with AccessibleObjectFromWindow - which I also learnt from you. I usually have more than one instance of Excel running, and I use that API to iterate through each of the workbooks to export out the modules, etc, so AccessibleObjectFromWindow serves my needs. Presumably, from that point (the workbook object) you could conceivably get the parent (Application) object, no?

I see your mention of the Running Object Table - @sancarn tried to explain it to me once, but it went way over my head. I understand it's very interesting though. :-)
 
Upvote 0
Presumably, from that point (the workbook object) you could conceivably get the parent (Application) object, no?
Yes, but AccessibleObjectFromWindow will only work if there is at least one workbook open in the target instance hence the need to find an alternative solution that works even when no workbook(s) is(are) currently open. The code I posted in this thread overcomes this problem as it works regardless of whether the target instance(s) have workbook(s) open or not.

I see your mention of the Running Object Table - @sancarn tried to explain it to me once, but it went way over my head. I understand it's very interesting though.
The ROT is basically just a look up table in which COM objects can register themselves so other client objects can bind to them via monikers.

A ROT viewer comes with visual studio. Below is a copy of the IROTVIEW exe I have:

IROTVIEW.EXE

IROT.png


There are interfaces the programmer can use to iterate the ROT and bind to the COM objects via the monikers.
 
Upvote 0
So it seems like your code above is like some kind of GetObjectEx? Whereas GetObject, as you say, retrieves the first retrieves the first instance, this iterates through all of them. This would be useful when trying to retrieve and clean up 'lost' instances of Excel etc that are invisible.

Thank you for the ROT explanation and the software reference - I'll have to have a play with it.
 
Upvote 0
VBA Code:
Call CoRegisterMessageFilter(0&, lMsgFilter)
Set oDisp = HwndToDispatch(hChild)
...
Private Function HwndToDispatch(ByVal Hwnd As LongPtr) As Object
    ...
    lResult = SendMessage(Hwnd, WM_GETOBJECT, NULL_PTR, ByVal OBJID_CLIENT)
    ...
            If ObjectFromLresult(lResult, VarPtr(tGUID(0&)), NULL_PTR, oDisp) = S_OK Then
    ...
End Function

Also it's the first time I have ever seen CoRegisterMessageFilter interesting stuff... Does usage of AccessibleObjectFromWindow not work on these command bars then? Seems a little peculiar that you are using WM_GETOBJECT directly. I would have assumed AccessibleObjectFromWindow would work just as well...
 
Upvote 0
Also it's the first time I have ever seen CoRegisterMessageFilter interesting stuff... Does usage of AccessibleObjectFromWindow not work on these command bars then? Seems a little peculiar that you are using WM_GETOBJECT directly. I would have assumed AccessibleObjectFromWindow would work just as well...
In theory, AccessibleObjectFromWindow should work for obtaining the IDispatch interface of the commandbars as per the documentation but, for some reason I am not able to make it work ! Only WM_GETOBJECT worked for me.

Untitledpng.png



I used CoRegisterMessageFilter to prevent the client application from hanging when the server app is not responding.
 
Upvote 0
Hmmm a ROT inspector in VBA would be nice 🤔 Off-topic: Dan and I have been looking at making a clipboard inspector as of late :)
I have just finished writing the vba code that replicates the commercial ROT Viewer. No references to any typelibs required ... Just plain vba low level calls on interfaces.

I have only tested the code on 2016 x64bit office applications ... I hope someone can test it on other office versions, specially x32bit office, to see if everything is ok.

File Download:
ROT_VIEWER_VBA.xlsm









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

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

Private Enum VTBL_OFFSETS
    QueryInterface = 0&
    AddRef = 1& * PTR_SIZE
    Release = 2& * PTR_SIZE
    EnumRunning = 9& * PTR_SIZE
    RunningGetObject = 6& * PTR_SIZE
    EnumMoniker_Next = 3& * PTR_SIZE
    Hash = 14& * PTR_SIZE
    IsRunning = 15& * PTR_SIZE
    GetTimeOfLastChange = 16& * PTR_SIZE
    Moniker_Inverse = 17& * PTR_SIZE
    GetDisplayName = 20& * PTR_SIZE
    IsSystemMoniker = 22& * PTR_SIZE
End Enum

Private Enum tagMKSYS
    MKSYS_NONE = 0&
    MKSYS_GENERICCOMPOSITE = 1&
    MKSYS_FILEMONIKER = 2&
    MKSYS_ANTIMONIKER = 3&
    MKSYS_ITEMMONIKER = 4&
    MKSYS_POINTERMONIKER = 5&
    MKSYS_CLASSMONIKER = 7&
    MKSYS_OBJREFMONIKER = 8&
    MKSYS_SESSIONMONIKER = 9&
    MKSYS_LUAMONIKER = 10&
End Enum

Private Type FILETIME
    dwLowDateTime  As Long
    dwHighDateTime As Long
End Type

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetRunningObjectTable Lib "ole32.dll" (ByVal dwReserved As Long, pROT As LongPtr) As Long
    Private Declare PtrSafe Function CreateBindCtx Lib "ole32.dll" (ByVal dwReserved As Long, pBindCtx As LongPtr) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long
    Private Declare PtrSafe Function ProgIDFromCLSID Lib "ole32.dll" (ByRef CLSID As Any, ByRef lplpszProgID As LongPtr) As Long
    Private Declare PtrSafe Function DispCallFunc Lib "OLEAUT32.DLL" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
    Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
    Private Declare PtrSafe Function SystemTimeToVariantTime Lib "OLEAUT32.DLL" (lpSystemTime As SYSTEMTIME, vtime As Date) As Long
    Private Declare PtrSafe Function SysReAllocString Lib "OLEAUT32.DLL" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As LongPtr)
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetRunningObjectTable Lib "ole32.dll" (ByVal dwReserved As Long, pROT As LongPtr) As Long
    Private Declare Function CreateBindCtx Lib "ole32.dll" (ByVal dwReserved As Long, pBindCtx As LongPtr) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long
    Private Declare Function ProgIDFromCLSID Lib "ole32.dll" (ByRef CLSID As Any, ByRef lplpszProgID As LongPtr) As Long
    Private Declare Function DispCallFunc Lib "OLEAUT32.DLL" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
    Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
    Private Declare Function SystemTimeToVariantTime Lib "OLEAUT32.DLL" (lpSystemTime As SYSTEMTIME, vtime As Date) As Long
    Private Declare Function SysReAllocString Lib "OLEAUT32.DLL" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As LongPtr)
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#End If

Public Type MONIKER_INFO
    ComRef As Object
    ComPointer As LongPtr
    DisplayName As String
    Inverse As String
    ProgID As String
    Type As String
    ObjectType As String
    HashValue As Long
    LastChange As Date
    IsRunning As Boolean
End Type



Public Function Get_ROT_Info() As MONIKER_INFO()

    '////////////////////////////////////////////////////////////////////////////
        '   *Get_ROT_Info* Function:
        '   Returns an array of MONIKER_INFO Types filled with the ROT info.
    '////////////////////////////////////////////////////////////////////////////

    Const ROT_INTERFACE_ID = "{00000010-0000-0000-C000-000000000046}"
    Const IID_DISPATCH = "{00020400-0000-0000-C000-000000000046}"
    Const S_OK = 0&
 
    Dim pROT As LongPtr, pRunningObjectTable As LongPtr, pEnumMoniker As LongPtr
    Dim pMoniker As LongPtr, pBindCtx As LongPtr, pDisplayName As LongPtr
    Dim ppunkObject As LongPtr, pDisp As LongPtr
    Dim ppMoniker As LongPtr, pDisplayInverseName As LongPtr
    Dim uGUID(0& To 3&) As Long
    Dim lRet As Long, nCount As Long, i As Long
    Dim oTmpObj As Object
    Dim tMKInfo As MONIKER_INFO
    Dim vArr() As MONIKER_INFO
    Dim tFTime As FILETIME
    Dim lMonikerType As tagMKSYS
    Dim pFileTime As LongPtr
    Dim pProgID As LongPtr
    Dim lHash As Long
    Dim sIIDString As String
    Dim sDisplayName As String, sInverse As String
    Dim bRunning As Boolean
 
 
    lRet = GetRunningObjectTable(0&, pROT)
    If lRet = S_OK Then
        lRet = CreateBindCtx(0&, pBindCtx)
        If lRet = S_OK Then
            lRet = IIDFromString(StrPtr(ROT_INTERFACE_ID), VarPtr(uGUID(0&)))
            If lRet = S_OK Then
                If vTblStdCall(pROT, QueryInterface, vbLong, VarPtr(uGUID(0&)), (VarPtr(pRunningObjectTable))) = S_OK Then
                    If vTblStdCall(pRunningObjectTable, EnumRunning, vbLong, (VarPtr(pEnumMoniker))) = S_OK Then
                        nCount = nCount + 1&
                        While vTblStdCall(pEnumMoniker, EnumMoniker_Next, vbLong, nCount, VarPtr(pMoniker), VarPtr(nCount)) = S_OK
                            With tMKInfo
                                .DisplayName = ""
                                .Inverse = ""
                                .ProgID = ""
                                .ObjectType = ""
                                .Type = ""
                                .ComPointer = NULL_PTR
                                .HashValue = 0&
                                .LastChange = 0&
                                .IsRunning = False
                                Set tMKInfo.ComRef = Nothing
                            End With
                            lRet = vTblStdCall(pMoniker, GetDisplayName, vbLong, pBindCtx, NULL_PTR, VarPtr(pDisplayName))
                            If lRet = S_OK Then
                                sDisplayName = GetStrFromPtrW(pDisplayName)
                            End If
                            lRet = vTblStdCall(pMoniker, Hash, vbLong, VarPtr(lHash))
                            lRet = vTblStdCall(pMoniker, IsRunning, vbLong, pBindCtx, NULL_PTR, NULL_PTR)
                            If lRet = S_OK Then bRunning = True
                            lRet = vTblStdCall(pMoniker, GetTimeOfLastChange, vbLong, pBindCtx, NULL_PTR, VarPtr(pFileTime))
                            lRet = vTblStdCall(pMoniker, IsSystemMoniker, vbLong, VarPtr(lMonikerType))
                            lRet = vTblStdCall(pMoniker, Moniker_Inverse, vbLong, VarPtr(ppMoniker))
                            If lRet = S_OK Then
                                lRet = vTblStdCall(ppMoniker, GetDisplayName, vbLong, pBindCtx, NULL_PTR, VarPtr(pDisplayInverseName))
                                If lRet = S_OK Then
                                    sInverse = GetStrFromPtrW(pDisplayInverseName)
                                End If
                                lRet = vTblStdCall(ppMoniker, Release, vbLong)
                            End If
                            With tMKInfo
                                .DisplayName = sDisplayName
                                .Inverse = sInverse
                                .HashValue = lHash
                                .IsRunning = bRunning
                                .Type = MKSYSToMKSYSType(lMonikerType)
                                Call CopyMemory(ByVal tFTime, pFileTime, LenB(tFTime))
                                    .LastChange = GetLastChange(tFTime)
                                Call CopyMemory(ByVal tFTime, NULL_PTR, LenB(tFTime))
                                sIIDString = Replace(.DisplayName, "!", "")
                                lRet = IIDFromString(StrPtr(sIIDString), VarPtr(uGUID(0&)))
                                If lRet = S_OK Then
                                    If ProgIDFromCLSID(uGUID(0&), pProgID) = S_OK Then
                                        .ProgID = GetStrFromPtrW(pProgID)
                                    End If
                                End If
                            End With
                            lRet = vTblStdCall(pROT, RunningGetObject, vbLong, pMoniker, VarPtr(ppunkObject))
                            If ppunkObject Then
                                lRet = IIDFromString(StrPtr(IID_DISPATCH), VarPtr(uGUID(0&)))
                                lRet = vTblStdCall(ppunkObject, 0&, vbLong, VarPtr(uGUID(0&)), VarPtr(pDisp))
                                If pDisp Then
                                    On Error Resume Next
                                        Call CopyMemory(oTmpObj, pDisp, PTR_SIZE)
                                        Call vTblStdCall(pDisp, Release, vbLong)
                                        If Not oTmpObj Is Nothing Then
                                            With tMKInfo
                                                Set .ComRef = oTmpObj
                                                .ComPointer = ObjPtr(oTmpObj)
                                                .ObjectType = TypeName(oTmpObj)
                                            End With
                                        End If
                                        Call CopyMemory(oTmpObj, 0&, PTR_SIZE)
                                    On Error GoTo 0
                                    ReDim Preserve vArr(i)
                                    vArr(i) = tMKInfo:  i = i + 1&
                                End If
                                Call vTblStdCall(ppunkObject, Release, vbLong)
                            End If
                            Call vTblStdCall(pMoniker, Release, vbLong)
                        Wend
                        If Not Not (vArr) Then
                            Get_ROT_Info = vArr
                        End If
                    End If
                End If
            End If
        End If
    End If
 
    Call vTblStdCall(pEnumMoniker, Release, vbLong)
    Call vTblStdCall(pBindCtx, Release, vbLong)
    Call vTblStdCall(pRunningObjectTable, Release, vbLong)
    Call vTblStdCall(pROT, Release, vbLong)

End Function

Private Function GetStrFromPtrW(ByVal Ptr As LongPtr) As String
    SysReAllocString VarPtr(GetStrFromPtrW), Ptr
End Function

Private Function GetLastChange(FTime As FILETIME) As Date
    Dim sSysTime As SYSTEMTIME
    Call FileTimeToLocalFileTime(FTime, FTime)
    Call FileTimeToSystemTime(FTime, sSysTime)
    Call SystemTimeToVariantTime(sSysTime, GetLastChange)
End Function

Private Function MKSYSToMKSYSType(ByVal eMKSYS As tagMKSYS) As String
    Select Case eMKSYS
        Case 0&
            MKSYSToMKSYSType = "NONE"
        Case 1&
            MKSYSToMKSYSType = "Generic Composite"
        Case 2&
            MKSYSToMKSYSType = "File Moniker"
        Case 3&
            MKSYSToMKSYSType = "Anti Moniker"
        Case 4&
            MKSYSToMKSYSType = "Item Moniker"
        Case 5&
            MKSYSToMKSYSType = "Pointer Moniker"
        Case 7&
            MKSYSToMKSYSType = "Class Moniker"
        Case 8&
            MKSYSToMKSYSType = "ObjRef Moniker"
        Case 9&
            MKSYSToMKSYSType = "Session Moniker"
        Case 10&
            MKSYSToMKSYSType = "Lua Moniker"
    End Select
End Function

Private Function vTblStdCall( _
    ByVal InterfacePointer As LongPtr, _
    ByVal VTableOffset As Long, _
    ByVal FunctionReturnType As Long, _
    ParamArray FunctionParameters() As Variant _
) As Variant
 
    Const CC_STDCALL = 4&
    Dim vParamPtr() As LongPtr
    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function
 
    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0& To 0&)
        ReDim vParamType(0& To 0&)
    Else
        ReDim vParamPtr(0& To pCount - 1&)
        ReDim vParamType(0& To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If
                                                   
    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CC_STDCALL, FunctionReturnType, pCount, vParamType(0&), vParamPtr(0&), vRtn)
    If pIndex = 0& Then
        vTblStdCall = vRtn
    Else
        SetLastError pIndex
    End If

End Function


2- Code Usage In the Userform Module:
VBA Code:
Option Explicit

Private tMKInfo() As MONIKER_INFO


Private Sub UserForm_Initialize()
    With lbxMonikerInfo
        .ColumnHeads = False
        .ColumnCount = 2&
        .ColumnWidths = "100;300"
        .Locked = True
        .TabStop = False
    End With
    Call Update
End Sub

Private Sub btnUpdate_Click()
    Call Update
End Sub

Private Sub btnClose_Click()
    Unload Me
End Sub

Private Sub Update()
    Dim i As Long
    With lbxMonikers
        .SetFocus
        .Clear
        tMKInfo = Get_ROT_Info
        For i = LBound(tMKInfo) To UBound(tMKInfo)
            .AddItem "[ " & i + 1& & " ]" & vbTab & tMKInfo(i).DisplayName
        Next i
        .ListIndex = 0&
    End With
End Sub

Private Sub lbxMonikers_Change()
    With lbxMonikerInfo
        .Clear
        If lbxMonikers.ListIndex <> -1& Then
            .AddItem
            .List(0, 0) = "Display Name: "
            .List(0, 1) = tMKInfo(lbxMonikers.ListIndex).DisplayName
            .AddItem
            .List(1, 0) = "Inverse: "
            .List(1, 1) = tMKInfo(lbxMonikers.ListIndex).Inverse
            .AddItem
            .List(2, 0) = "Object Type: "
            .List(2, 1) = tMKInfo(lbxMonikers.ListIndex).ObjectType
            .AddItem
            .List(3, 0) = "ProgID: "
            .List(3, 1) = tMKInfo(lbxMonikers.ListIndex).ProgID
            .AddItem
            .List(4, 0) = "Moniker Type: "
            .List(4, 1) = tMKInfo(lbxMonikers.ListIndex).Type
            .AddItem
            .List(5, 0) = "Hash Value: "
            .List(5, 1) = "0x" & Hex(tMKInfo(lbxMonikers.ListIndex).HashValue)
            .AddItem
            .List(6, 0) = "COM Pointer: "
            .List(6, 1) = tMKInfo(lbxMonikers.ListIndex).ComPointer
            .AddItem
            .List(7, 0) = "Running: "
            .List(7, 1) = CStr(tMKInfo(lbxMonikers.ListIndex).IsRunning)
            .AddItem
            .List(8, 0) = "Last Change: "
            .List(8, 1) = tMKInfo(lbxMonikers.ListIndex).LastChange
        End If
    End With
End Sub
 
Last edited:
Upvote 0
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...
VBA Code:
Private Sub UserForm_Activate()
UserForm1.btnUpdate.SetFocus
End Sub
Thanks for sharing your efforts Jaafar. Dave
 
Upvote 0
Works perfectly for me - Windows 11 - MS365 - 64bit.
It seems to mirror the functionality (and appearances) of the ROTVIEW file you posted, which is great.
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 think I know someone with 32bit Office, so will check in with them to see if it works for them. On that, I did a poll on Reddit a while ago to see who was using what bitness of Office - it was overwhelmingly either 64bit being used or 64bit and 32bit. I would be interesting if MrExcel could undertake an equivalent poll - it would be useful a stat.
 
Upvote 0

Forum statistics

Threads
1,224,547
Messages
6,179,440
Members
452,915
Latest member
hannnahheileen

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