Ever wished there was an 'Applications' Collection ?!!!

Jaafar Tribak · Oct 11, 2006

Ok, I admit it, designing a Collection of all the XL applications currently running in one's machine and use it nearly in the same way as other native collections in the XL object model is no doubt of little practical use for most XL users but I 've long wanted to do this if only for the challenge of it as well as for the sake of learning.

This subject was discussed here http://www.mrexcel.com/board2/viewtopic.php?t=185175&highlight=communicating but was abandoned.

Also, let me just say that the method I've attempted here to do this is by no means an elegant robust solution.It's actually just a hack\workaround which also requires quite a bit of setting up and can also be prone to errors if not handled carefully.

For a robust solution, the only way I know of is by registering and using a third party type lib : OLELIB.TLB written in C with which one can get a pointer to every object in the ROT but then again, what we want here is a VBA-Only solution !!

Set Up required - Follow these 2 STEPS :

STEP1- Create a workbook , place the following code in the 'ThisWorkBook' Module , save it as an AddIn and name it : AppsCollection.xla

AddIn Code

Code:

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private bSkipCloseEvent As Boolean


Private Sub Workbook_Open()

    Dim oWB As Workbook
    Dim lHwnd As Long
    Dim vAddInLocations As Variant
    Dim sMaxInstances As String
    
    '\\check if there is a max allowed # of xl instances
    '\\in the registry
    sMaxInstances = GetSetting("XLInstances", "MaxAllowed", "Max=")
    
    '\\if there is,check how many xl instances are already open
    If Val(sMaxInstances) <> 0 Then
        vAddInLocations = GetAllSettings("MyRunningApps", "AddInLocations")
        
        '\\if this xl instance is going to exceed the allowed #
        '\\then set a flag,inform the user and close it
        If UBound(vAddInLocations, 1) >= Val(sMaxInstances) - 1 Then
            GoTo exitHere
        End If
    End If
    
    
    '\\however,if it's ok to open this instance then see if it is the first one.
    '\\if it is not,save this addin temporarly under a unique name
    '\this will permit to retrieve a pointer to the parent application !
    lHwnd = FindWindow("XLMAIN", Application.Caption)
    If Me.ReadOnly Then
        Me.SaveAs Environ("temp") & Application.PathSeparator & _
        CStr(lHwnd) & "_" & Me.Name
    End If
    
    '\always make an entry in the registry so the addin path
    '\\can be later retrieved by the 'Applications' class
    SaveSetting "MyRunningApps", "AddInLocations", CStr(Me.Name), CStr(Me.FullName)
    Exit Sub
    
    '\\we got here means there are more than the allowed # of instances
    '\\quit and get out now skipping the Before_Close event handler
exitHere:
    bSkipCloseEvent = True
    MsgBox "You have exceed the maximum number of allowed instances", vbExclamation
    Application.Quit

End Sub


Private Sub Workbook_BeforeClose(Cancel As Boolean)

    '\\if user is closing this xl instance delete its corresponding
    '\\registry entry to indicate it's no longer running
    If bSkipCloseEvent Then Exit Sub
        DeleteSetting "MyRunningApps", "AddInLocations", CStr(Me.Name)
        
        '\\if it's not the first instance delete the associated temp addin
        If Me.Name <> "AppsCollection.xla" Then
        KillMyself Me
    End If

End Sub


Private Sub KillMyself(oWB As Workbook)

    Dim sPathName As String
    
    sPathName = oWB.FullName
    oWB.ChangeFileAccess xlReadOnly
    Kill sPathName
    oWB.Saved = True

End Sub

Now, install this addin before you can use the Class shown in the next step.

STEP2- Create a workbook , add a Class Module to it's VBProject and name the Class : clsAppsCollection.
Place the following code in this Class Module :

Code:

Option Explicit

Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function GetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31

Private oColApps As Collection
Private ap As Application
Private byMaxInstances As Byte
Private WithEvents wbCloseEvent As Workbook



Public Property Get Count() As Long

    Call UpdateAppsCollection
    Count = oColApps.Count

End Property


Public Property Let MaximumInstancesAllowed(ByVal vNewValue As Byte)
    '\\store this value in the registry so it can be accessed by all
    '\\other running xl applications
    SaveSetting "XLInstances", "MaxAllowed", "Max=", CStr(vNewValue)
    byMaxInstances = vNewValue

End Property


Public Property Get MaximumInstancesAllowed() As Byte

    MaximumInstancesAllowed = byMaxInstances

End Property


Public Function OpenNew _
(Optional visible As Boolean = True, Optional WBPathName As Variant) As Excel.Application

    Dim sErrMsg As String

    If Not WeAreExceedingMaxXLInstances Then
        '\\if there is 'WBPathName' this xl instance will open it
        If Not IsMissing(WBPathName) Then
            If Len(Dir(WBPathName)) <> 0 Then

                Set OpenNew = OpenNewXLApp(visible, WBPathName)
            Else
            '\\wrong pathname entered ?, warn the user and get out
                sErrMsg = sErrMsg & "Check the spelling of the path name."
                MsgBox "Path name : ' " & WBPathName & " '  not found." & vbCrLf _
                & vbCrLf & sErrMsg, vbExclamation
            End If
        Else
            Set OpenNew = OpenNewXLApp(visible)
        End If
    End If
     
End Function


Public Function Item(NameOrIndex As Variant) As Excel.Application

'\\this routine allows to reference the applications by their index #
'\\or the name of any of its children workbooks for easier use of this proprety

    Dim i As Byte
    Dim oWBk As Workbook
    Call UpdateAppsCollection
    If Not IsNumeric(NameOrIndex) Then
        For i = 1 To oColApps.Count
            For Each oWBk In oColApps(i).Workbooks
                If UCase(oWBk.Name) = UCase(NameOrIndex) Then
                    Set Item = oColApps(i)
                    Exit Function
                End If
            Next oWBk
        Next i
    End If
    Set Item = oColApps(NameOrIndex)

End Function


Public Sub ActivateApp(App As Excel.Application)
    
    '\\this is just a nice convinience
    '\\when you want to quickly activate one
    '\\particular xl instance

    Call UpdateAppsCollection
    If App.visible Then

        App.WindowState = xlMaximized
        AppActivate App.Caption
    End If

End Sub


Public Property Get HostComputer() As String
    
    '\\property similar to the standard Parent prop
    
    Dim lLen As Long
    Dim sBuffer As String
    'Create a buffer
    lLen = MAX_COMPUTERNAME_LENGTH + 1
    sBuffer = Space(lLen)
    'Get the computer name
    GetComputerName sBuffer, lLen
    'get only the actual data
    sBuffer = Left(sBuffer, lLen)
    'Show the computer name
    HostComputer = sBuffer

End Property


Private Sub Class_Initialize()
    'set up the 'Before_Close' event sink
    Set wbCloseEvent = ThisWorkbook

End Sub


Private Sub wbCloseEvent_BeforeClose(Cancel As Boolean)
    '\\make sure we delete the registry entry that
    '\\stores the # of xl instances once the class workbook is closed
    On Error Resume Next
    DeleteSetting "XLInstances"

End Sub


Private Sub UpdateAppsCollection()

    '\\this routine updates the current # of insatnces
    '\\and assigned their respective pointers to the module
    '\\level collection.
    '\\this routine is run every time a member of this class
    '\\is executed. this is vital to keep upto date with
    '\\the changing number of open xl instances.
    
        Dim i As Byte
    Dim vAddInLocations As Variant

    Set oColApps = New Collection
    vAddInLocations = GetAllSettings("MyRunningApps", "AddInLocations")
    For i = LBound(vAddInLocations, 1) To UBound(vAddInLocations, 1)
        oColApps.Add GetObject((vAddInLocations(i, 1))).Parent
    Next i

End Sub


Private Function WeAreExceedingMaxXLInstances() As Boolean

    Dim vAddInLocations As Variant

    vAddInLocations = GetAllSettings("MyRunningApps", "AddInLocations")
    If byMaxInstances <> 0 Then
        If UBound(vAddInLocations, 1) >= byMaxInstances - 1 Then
            WeAreExceedingMaxXLInstances = True
        End If
    End If

End Function


Private Function OpenNewXLApp _
(Optional ByVal bVisible As Boolean = True, Optional ByVal sWBPathName As Variant) As Excel.Application

    Dim oNewApp As Application
    Dim sAddInPathName As String
    
    Set oNewApp = CreateObject("EXCEL.APPLICATION")
    oNewApp.UserControl = True
    sAddInPathName = AddIns("AppsCollection").FullName
    oNewApp.Workbooks.Open sAddInPathName
    Call UpdateAppsCollection
    oNewApp.visible = bVisible
    If Not IsMissing(sWBPathName) Then
        oNewApp.Workbooks.Open sWBPathName
    End If
    Set OpenNewXLApp = oNewApp

End Function

That's it.

Here are two examples you can try once the AddIn has been insatlled & loaded and the Class has been added to your project.

Start a few instances of Excel and run the test routine below :

Example 1

Code:

'In a Standard Module

Option Explicit

Private Applications As clsAppsCollection

Sub Test()

    '\\open a few xl applications instances and
    '\\run this code to create an 'Applications' collection
    '\\and display info about each xl instance
    
    
    Dim App As Excel.Application
    Dim i As Byte, j As Byte
    Dim sMsg As String
    
    Set Applications = New clsAppsCollection
    With Applications
        For i = 1 To .Count
            sMsg = sMsg & " Application:  " & i & vbCrLf
            sMsg = sMsg & "--------------" & vbCrLf
            sMsg = sMsg & " WorkBooks Count:  " & _
            Applications.Item(i).Workbooks.Count & vbCrLf & vbCrLf
            For j = 1 To .Item(i).Workbooks.Count
                With .Item(i).Workbooks(j)
                    sMsg = sMsg & " WorkBook:  " & j & "  Sheets Count : " _
                    & .Sheets.Count & vbCrLf
                End With
            Next j
            sMsg = sMsg & vbCrLf & vbCrLf
        Next i
    End With
    MsgBox sMsg

End Sub

Example 2:

Code:

'In a Standard Module

Option Explicit

Private Applications As clsAppsCollection


Sub Test2()
    '\\allow no more than 3 xl instances @ a time
    '\\and use the OpenNew Method to open one
    
    Set Applications = New clsAppsCollection
    With Applications
        .MaximumInstancesAllowed = 3
        .OpenNew
    End With

End Sub

A word of caution for anyone trying this code! The code in this project makes use of the Registry to store temporary entries inside the 'VB and VBA program Settings' Key during the AddIn aut

pen event. I believe this is safe but if you happen to edit the code, subtle errors can arise and can be tricky to locate. You may have to manually delete the above temp reg entries by running the RegEdit.exe Applet.

The MaximumInstancesAllowed Property can be particularly troublesome if edited !

Tested in XL 2002 Office XP.

Any feedback would be much appreciated.

Regards.

Jaafar Tribak · Oct 17, 2006

Jon-

Thanks for taking an interest in this anyway.

Regards.

Legacy 98055 · Oct 17, 2006

Jaafar. The solution posted on experts-exchange seems to be what you are looking for. Correct? It appears to answer the question in your previous topic as well. I edited that solution to return all running instances to a collection...

The problem with your hack using an addin is it will not detect instances if they are initiated by way of automation. Of course if there happens to be at least one running instance started in some other way, your code should work.

ApplicationCollection.zip

Usage:
<table width="100%" border="1" bgcolor="White" style="filter

rogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD> Sub Example()
 Dim c As Collection

 Set c = GetAllInstances
 If Not c Is Nothing Then
 MsgBox "There were " & c.Count & " instances added to your collection."
 End If
 End Sub
</td></tr></table><button onclick='document.all("10172006203352390").value=document.all("10172006203352390").value.replace(/ \s\s/g,"");document.all("10172006203352390").value=document.all("10172006203352390").value.replace(/ /g,"");window.clipboardData.setData("Text",document.all("10172006203352390").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="10172006203352390" wrap="virtual">
Sub Example()
Dim c As Collection

Set c = GetAllInstances
If Not c Is Nothing Then
MsgBox "There were " & c.Count & " instances added to your collection."
End If
End Sub</textarea>

Mod "ExcelInstanceCollection":
<table width="100%" border="1" bgcolor="White" style="filter

rogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD> Option Explicit

 Private Declare Function GetRunningObjectTable Lib "ole32.dll" (ByVal dwReserved As Long, pROT As Long) As Long
 Private Declare Function CreateBindCtx Lib "ole32.dll" (ByVal dwReserved As Long, pBindCtx As Long) As Long
 Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

 Private Declare Sub OleInitialize Lib "ole32.dll" (pvReserved As Any)
 Private Declare Sub OleUninitialize Lib "ole32.dll" ()

 Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)

 Private Declare Function PutMem2 Lib "msvbvm60" (ByVal pWORDDst As Long, ByVal NewValue As Long) As Long
 Private Declare Function PutMem4 Lib "msvbvm60" (ByVal pDWORDDst As Long, ByVal NewValue As Long) As Long
 Private Declare Function GetMem4 Lib "msvbvm60" (ByVal pDWORDSrc As Long, ByVal pDWORDDst As Long) As Long
 Private Declare Function VarPtr Lib "msvbvm60" (var As Any) As Long

 Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
 Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

 Private Declare Function CopyStringA Lib "kernel32" Alias "lstrcpyA" (ByVal NewString As String, ByVal OldString As Long) As Long
 Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
 Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
 Private Declare Function WideCharToMultiByte Lib "kernel32" _
 (ByVal codepage As Long, ByVal dwFlags As Long, _
 lpWideCharStr As Any, ByVal cchWideChar As Long, _
 lpMultiByteStr As Any, ByVal cchMultiByte As Long, _
 ByVal lpDefaultChar As String, _
 ByVal lpUsedDefaultChar As Long) As Long

 Private Const GMEM_FIXED As Long = &H0
 Private Const asmPUSH_imm32 As Byte = &H68
 Private Const asmRET_imm16 As Byte = &HC2
 Private Const asmRET_16 As Long = &H10C2&
 Private Const asmCALL_rel32 As Byte = &HE8

 'IUnknown vTable ordinals
 Private Const unk_QueryInterface As Long = 0
 Private Const unk_AddRef As Long = 1
 Private Const unk_Release As Long = 2
 Private Const vtbl_ROT_EnumRunning = 9
 Private Const vtbl_EnumMoniker_Next = 3
 Private Const vtbl_Moniker_GetDisplayName = 20

 'Function to call Interface members by ordinal in VTable
 Private Function CallInterface(ByVal pInterface As Long, ByVal FuncOrdinal As Long, ByVal ParamsCount As Long, Optional ByVal p1 As Long = 0, Optional ByVal p2 As Long = 0, Optional ByVal p3 As Long = 0, Optional ByVal p4 As Long = 0, Optional ByVal p5 As Long = 0, Optional ByVal p6 As Long = 0, Optional ByVal p7 As Long = 0, Optional ByVal p8 As Long = 0, Optional ByVal p9 As Long = 0, Optional ByVal p10 As Long = 0) As Long
 Dim i As Long, t As Long
 Dim hGlobal As Long, hGlobalOffset As Long

 If ParamsCount < 0 Then Err.Raise 5 'invalid call
 If pInterface = 0 Then Err.Raise 5

 '5 bytes for each parameter
 '5 bytes - PUSH this
 '5 bytes - call member function
 '3 bytes - ret 0x0010, pop CallWindowProc
 '1 byte - dword align.

 hGlobal = GlobalAlloc(GMEM_FIXED, 5 * ParamsCount + 5 + 5 + 3 + 1)
 If hGlobal = 0 Then Err.Raise 7 'insuff. memory
 hGlobalOffset = hGlobal

 If ParamsCount > 0 Then
 t = VarPtr(p1)
 For i = ParamsCount - 1 To 0 Step -1
 PutMem2 hGlobalOffset, asmPUSH_imm32
 hGlobalOffset = hGlobalOffset + 1
 GetMem4 t + i * 4, hGlobalOffset
 hGlobalOffset = hGlobalOffset + 4
 Next
 End If

 'First member of any interface - this. Assign...
 PutMem2 hGlobalOffset, asmPUSH_imm32
 hGlobalOffset = hGlobalOffset + 1
 PutMem4 hGlobalOffset, pInterface
 hGlobalOffset = hGlobalOffset + 4

 'Call IFace Function by its ordinal
 PutMem2 hGlobalOffset, asmCALL_rel32
 hGlobalOffset = hGlobalOffset + 1

 GetMem4 pInterface, VarPtr(t) 'dereference: find vTable
 GetMem4 t + FuncOrdinal * 4, VarPtr(t) 'Function offset in vTable, dereference
 PutMem4 hGlobalOffset, t - hGlobalOffset - 4
 hGlobalOffset = hGlobalOffset + 4

 'all interfaces are stdcall, so forget about stack clearing
 PutMem4 hGlobalOffset, asmRET_16 'ret 0x0010

 CallInterface = CallWindowProc(hGlobal, 0, 0, 0, 0)

 GlobalFree hGlobal

 End Function

 Private Function StrFromPtrA(ByVal lpszA As Long, Optional nSize As Long = 0) As String
 Dim s As String, bTrim As Boolean
 If nSize = 0 Then
 nSize = lstrlenA(lpszA)
 bTrim = True
 End If
 s = String(nSize, Chr$(0))
 CopyStringA s, ByVal lpszA
 If bTrim Then s = TrimNULL(s)
 StrFromPtrA = s
 End Function

 Private Function StrFromPtrW(ByVal lpszW As Long, Optional nSize As Long = 0) As String
 Dim s As String, bTrim As Boolean
 If nSize = 0 Then
 nSize = lstrlenW(lpszW) * 2
 bTrim = True
 End If
 s = String(nSize, Chr$(0))
 ' CopyMemory ByVal StrPtr(s), ByVal lpszW, nSize ' VBA doesn't support StrPtr

WideCharToMultiByte 0, &H0, ByVal lpszW, -1, ByVal s, Len(s), &H0, &H0
 If bTrim Then s = TrimNULL(s)
 StrFromPtrW = s
 End Function

 Private Function TrimNULL(ByVal str As String) As String
 If InStr(str, Chr$(0)) > 0& Then
 TrimNULL = Left$(str, InStr(str, Chr$(0)) - 1&)
 Else
 TrimNULL = str
 End If
 End Function

 Public Function GetAllInstances() As Collection
 Dim pROT As Long, pEnumMoniker As Long, pMoniker As Long, pBindCtx As Long
 Dim ret As Long, nCount As Long, CheckForInstance As Boolean, Key As String
 Dim pName As Long, RegisteredName As String, ExcelApp As Application
 ret = GetRunningObjectTable(0, pROT)
 ret = CreateBindCtx(0, pBindCtx)
 CallInterface pROT, vtbl_ROT_EnumRunning, 1, VarPtr(pEnumMoniker)
 While CallInterface(pEnumMoniker, vtbl_EnumMoniker_Next, 3, 1, VarPtr(pMoniker), VarPtr(nCount)) = 0
 CallInterface pMoniker, vtbl_Moniker_GetDisplayName, 3, pBindCtx, 0, VarPtr(pName)
 'For win9x you'll need StrFromPtrA

 RegisteredName = StrFromPtrW(pName)
 If InStr(LCase(RegisteredName), "book") Then
 CheckForInstance = True
 Else
 Select Case Right(RegisteredName, 3)
 Case "xla", "slk", "dif", "csv", "txt", "prn", "dbf", "wq1", "wks", "wk1", "wk3", "wk4", "xlw", "xls", "xlt", "htm", "mht", "xml"
 CheckForInstance = True
 End Select
 Select Case Right(RegisteredName, 5)
 Case ".html", "mhtml"
 CheckForInstance = True
 End Select
 End If

 If CheckForInstance Then
 CheckForInstance = False
 If ParentIsExcel(RegisteredName, ExcelApp) Then
 If GetAllInstances Is Nothing Then Set GetAllInstances = New Collection
 Key = CStr(ObjPtr(ExcelApp))
 If Not InstanceAlreadyCollected(GetAllInstances, Key) Then
 GetAllInstances.Add ExcelApp, Key
 End If
 End If
 End If

 CallInterface pMoniker, unk_Release, 0
 CoTaskMemFree pName
 Wend
 CallInterface pEnumMoniker, unk_Release, 0
 CallInterface pBindCtx, unk_Release, 0
 CallInterface pROT, unk_Release, 0
 Exit Function

 End Function

 Private Function ParentIsExcel(ByVal RegisteredName As String, ExcelApp As Application) As Boolean
 On Error Resume Next

 Set ExcelApp = GetObject(RegisteredName).Parent
 If ExcelApp.Name = "Microsoft Excel" Then
 ParentIsExcel = True
 End If

 End Function

 Private Function InstanceAlreadyCollected(GetAllInstances As Collection, Key As String) As Boolean
 On Error GoTo Err_InstanceAlreadyCollected
 Dim o As Application
 Set o = GetAllInstances(Key)
 InstanceAlreadyCollected = True
 Err_InstanceAlreadyCollected:
 End Function
</td></tr></table><button onclick='document.all("10172006203442546").value=document.all("10172006203442546").value.replace(/ \s\s/g,"");document.all("10172006203442546").value=document.all("10172006203442546").value.replace(/ /g,"");window.clipboardData.setData("Text",document.all("10172006203442546").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="10172006203442546" wrap="virtual">
Option Explicit

Private Declare Function GetRunningObjectTable Lib "ole32.dll" (ByVal dwReserved As Long, pROT As Long) As Long
Private Declare Function CreateBindCtx Lib "ole32.dll" (ByVal dwReserved As Long, pBindCtx As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Private Declare Sub OleInitialize Lib "ole32.dll" (pvReserved As Any)
Private Declare Sub OleUninitialize Lib "ole32.dll" ()

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)

Private Declare Function PutMem2 Lib "msvbvm60" (ByVal pWORDDst As Long, ByVal NewValue As Long) As Long
Private Declare Function PutMem4 Lib "msvbvm60" (ByVal pDWORDDst As Long, ByVal NewValue As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (ByVal pDWORDSrc As Long, ByVal pDWORDDst As Long) As Long
Private Declare Function VarPtr Lib "msvbvm60" (var As Any) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Function CopyStringA Lib "kernel32" Alias "lstrcpyA" (ByVal NewString As String, ByVal OldString As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" _
(ByVal codepage As Long, ByVal dwFlags As Long, _
lpWideCharStr As Any, ByVal cchWideChar As Long, _
lpMultiByteStr As Any, ByVal cchMultiByte As Long, _
ByVal lpDefaultChar As String, _
ByVal lpUsedDefaultChar As Long) As Long

Private Const GMEM_FIXED As Long = &H0
Private Const asmPUSH_imm32 As Byte = &H68
Private Const asmRET_imm16 As Byte = &HC2
Private Const asmRET_16 As Long = &H10C2&
Private Const asmCALL_rel32 As Byte = &HE8

'IUnknown vTable ordinals
Private Const unk_QueryInterface As Long = 0
Private Const unk_AddRef As Long = 1
Private Const unk_Release As Long = 2
Private Const vtbl_ROT_EnumRunning = 9
Private Const vtbl_EnumMoniker_Next = 3
Private Const vtbl_Moniker_GetDisplayName = 20

'Function to call Interface members by ordinal in VTable
Private Function CallInterface(ByVal pInterface As Long, ByVal FuncOrdinal As Long, ByVal ParamsCount As Long, Optional ByVal p1 As Long = 0, Optional ByVal p2 As Long = 0, Optional ByVal p3 As Long = 0, Optional ByVal p4 As Long = 0, Optional ByVal p5 As Long = 0, Optional ByVal p6 As Long = 0, Optional ByVal p7 As Long = 0, Optional ByVal p8 As Long = 0, Optional ByVal p9 As Long = 0, Optional ByVal p10 As Long = 0) As Long
Dim i As Long, t As Long
Dim hGlobal As Long, hGlobalOffset As Long

If ParamsCount < 0 Then Err.Raise 5 'invalid call
If pInterface = 0 Then Err.Raise 5

'5 bytes for each parameter
'5 bytes - PUSH this
'5 bytes - call member function
'3 bytes - ret 0x0010, pop CallWindowProc
'1 byte - dword align.

hGlobal = GlobalAlloc(GMEM_FIXED, 5 * ParamsCount + 5 + 5 + 3 + 1)
If hGlobal = 0 Then Err.Raise 7 'insuff. memory
hGlobalOffset = hGlobal

If ParamsCount > 0 Then
t = VarPtr(p1)
For i = ParamsCount - 1 To 0 Step -1
PutMem2 hGlobalOffset, asmPUSH_imm32
hGlobalOffset = hGlobalOffset + 1
GetMem4 t + i * 4, hGlobalOffset
hGlobalOffset = hGlobalOffset + 4
Next
End If

'First member of any interface - this. Assign...
PutMem2 hGlobalOffset, asmPUSH_imm32
hGlobalOffset = hGlobalOffset + 1
PutMem4 hGlobalOffset, pInterface
hGlobalOffset = hGlobalOffset + 4

'Call IFace Function by its ordinal
PutMem2 hGlobalOffset, asmCALL_rel32
hGlobalOffset = hGlobalOffset + 1

GetMem4 pInterface, VarPtr(t) 'dereference: find vTable
GetMem4 t + FuncOrdinal * 4, VarPtr(t) 'Function offset in vTable, dereference
PutMem4 hGlobalOffset, t - hGlobalOffset - 4
hGlobalOffset = hGlobalOffset + 4

'all interfaces are stdcall, so forget about stack clearing
PutMem4 hGlobalOffset, asmRET_16 'ret 0x0010

CallInterface = CallWindowProc(hGlobal, 0, 0, 0, 0)

GlobalFree hGlobal

End Function

Private Function StrFromPtrA(ByVal lpszA As Long, Optional nSize As Long = 0) As String
Dim s As String, bTrim As Boolean
If nSize = 0 Then
nSize = lstrlenA(lpszA)
bTrim = True
End If
s = String(nSize, Chr$(0))
CopyStringA s, ByVal lpszA
If bTrim Then s = TrimNULL(s)
StrFromPtrA = s
End Function

Private Function StrFromPtrW(ByVal lpszW As Long, Optional nSize As Long = 0) As String
Dim s As String, bTrim As Boolean
If nSize = 0 Then
nSize = lstrlenW(lpszW) * 2
bTrim = True
End If
s = String(nSize, Chr$(0))
' CopyMemory ByVal StrPtr(s), ByVal lpszW, nSize ' VBA doesn't support StrPtr

WideCharToMultiByte 0, &H0, ByVal lpszW, -1, ByVal s, Len(s), &H0, &H0
If bTrim Then s = TrimNULL(s)
StrFromPtrW = s
End Function

Private Function TrimNULL(ByVal str As String) As String
If InStr(str, Chr$(0)) > 0& Then
TrimNULL = Left$(str, InStr(str, Chr$(0)) - 1&)
Else
TrimNULL = str
End If
End Function

Public Function GetAllInstances() As Collection
Dim pROT As Long, pEnumMoniker As Long, pMoniker As Long, pBindCtx As Long
Dim ret As Long, nCount As Long, CheckForInstance As Boolean, Key As String
Dim pName As Long, RegisteredName As String, ExcelApp As Application
ret = GetRunningObjectTable(0, pROT)
ret = CreateBindCtx(0, pBindCtx)
CallInterface pROT, vtbl_ROT_EnumRunning, 1, VarPtr(pEnumMoniker)
While CallInterface(pEnumMoniker, vtbl_EnumMoniker_Next, 3, 1, VarPtr(pMoniker), VarPtr(nCount)) = 0
CallInterface pMoniker, vtbl_Moniker_GetDisplayName, 3, pBindCtx, 0, VarPtr(pName)
'For win9x you'll need StrFromPtrA

RegisteredName = StrFromPtrW(pName)
If InStr(LCase(RegisteredName), "book") Then
CheckForInstance = True
Else
Select Case Right(RegisteredName, 3)
Case "xla", "slk", "dif", "csv", "txt", "prn", "dbf", "wq1", "wks", "wk1", "wk3", "wk4", "xlw", "xls", "xlt", "htm", "mht", "xml"
CheckForInstance = True
End Select
Select Case Right(RegisteredName, 5)
Case ".html", "mhtml"
CheckForInstance = True
End Select
End If

If CheckForInstance Then
CheckForInstance = False
If ParentIsExcel(RegisteredName, ExcelApp) Then
If GetAllInstances Is Nothing Then Set GetAllInstances = New Collection
Key = CStr(ObjPtr(ExcelApp))
If Not InstanceAlreadyCollected(GetAllInstances, Key) Then
GetAllInstances.Add ExcelApp, Key
End If
End If
End If

CallInterface pMoniker, unk_Release, 0
CoTaskMemFree pName
Wend
CallInterface pEnumMoniker, unk_Release, 0
CallInterface pBindCtx, unk_Release, 0
CallInterface pROT, unk_Release, 0
Exit Function

End Function

Private Function ParentIsExcel(ByVal RegisteredName As String, ExcelApp As Application) As Boolean
On Error Resume Next

Set ExcelApp = GetObject(RegisteredName).Parent
If ExcelApp.Name = "Microsoft Excel" Then
ParentIsExcel = True
End If

End Function

Private Function InstanceAlreadyCollected(GetAllInstances As Collection, Key As String) As Boolean
On Error GoTo Err_InstanceAlreadyCollected
Dim o As Application
Set o = GetAllInstances(Key)
InstanceAlreadyCollected = True
Err_InstanceAlreadyCollected:
End Function</textarea>

ApplicationCollection.zip

Jaafar Tribak · Oct 17, 2006

Tom. This is excellent !

Note that at least one Workbook has to be saved per application instance so that it registers in the ROT and the Parent application can be added to the collection.

I'll study the code more closely later.

Regards.

Legacy 98055 · Oct 17, 2006

Note that at least one Workbook has to be saved per application instance so that it registers in the ROT and the Parent application can be added to the collection.

I did not run into that limitation.

Ever wished there was an 'Applications' Collection ?!!!

Jaafar Tribak

Well-known Member

Jaafar Tribak

Well-known Member

Excel Facts

Legacy 98055

Guest

Jaafar Tribak

Well-known Member

Legacy 98055

Guest

Similar threads

Forum statistics

Share this page

Ever wished there was an 'Applications' Collection ?!!!

Jaafar Tribak

Well-known Member

Jaafar Tribak

Well-known Member

Excel Facts

Legacy 98055

Guest

Jaafar Tribak

Well-known Member

Legacy 98055

Guest

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock