CODEWITHSUNDEEP
excelvba
Pramod Pandit
Pramod Pandit

Reputation: 121

How to collect Excel.Application objects opened in a system?

I found the following code which is based on GetRunningObjectTable - WinAPI function.It collects all excel application objects into var array. The problem that i am having in this code is that when i press run, it says : "CollectROT.dll" cannot be found.Also I could not find the library for ROT(Running Object Table).

Public Declare PtrSafe Function GetRunningExcelApps Lib "CollectROT.dll" (ByRef result As Variant) As Long
Public Const dllname As String = "CollectROT.dll"
Public glbApp As Application

Public Function GetExcelAppCollection() As Variant
Dim var As Variant
Dim appcalc As Long
Dim app As Application

ChDir (ThisWorkbook.Path)

appcalc = GetRunningExcelApps(var)
If appcalc > 0 Then
GetExcelAppCollection = var
Else
GetExcelAppCollection = Empty
End If
Exit Function
End Function

Upvotes: 0

Views: 754

Answers (2)

FaneDuru
FaneDuru

Reputation: 42236

  1. Please, copy the next code on top of a standard module (in the declarations area). It is designed to work in both (32 - 64 bit) versions:
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function FindWindowEx Lib "USER32" Alias _
            "FindWindowExA" (ByVal hWnd1 As LongPtr, _
            ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, _
            ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function IIDFromString Lib "ole32" _
            (ByVal lpsz As LongPtr, ByRef lpiid As GUID) As LongPtr
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" _
            (ByVal hWnd As LongPtr, ByVal dwId As LongPtr, ByRef riid As GUID, _
            ByRef ppvObject As Object) As LongPtr
#Else
    Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" _
            (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
             ByVal lpsz2 As String) As Long
    Private Declare Function IIDFromString Lib "ole32" _
            (ByVal lpsz As Long, ByRef lpiid As GUID) As Long
    Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _
            (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As GUID, _
             ByRef ppvObject As Object) As Long
#End If

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Const S_OK As Long = &H0
Private Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0
  1. Please, copy the next code in the same standard module. This should be the function doing what (I understood) you need:
Function GetExcelAppCollection() As Variant
   Dim dict As Object, i As Long
    #If VBA7 Then
        Dim hWinXL As LongPtr
    #Else
        Dim hWinXL As Long
    #End If
    Dim xlApp As Object 'Excel.Application

    Set dict = CreateObject("scripting.dictionary")
    
    hWinXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
    While hWinXL > 0
        i = i + 1
        If GetXLapp(hWinXL, xlApp) Then
            If Not dict.Exists(xlApp.hWnd) Then
                dict.Add xlApp.hWnd, xlApp
            End If
        End If
        hWinXL = FindWindowEx(0, hWinXL, "XLMAIN", vbNullString)
    Wend
     GetExcelAppCollection = dict.Items
End Function
  1. Copy the next function (called by the above one) in the same module:
#If VBA7 Then
    Function GetXLapp(hWinXL As LongPtr, xlApp As Object) As Boolean
    Dim hWinDesk As LongPtr, hWin7 As LongPtr
#Else
    Function GetXLapp(hWinXL As Long, xlApp As Object) As Boolean
    Dim hWinDesk As Long, hWin7 As Long
#End If

Dim obj As Object
Dim iid As GUID
    
    Call IIDFromString(StrPtr(IID_IDispatch), iid)
    hWinDesk = FindWindowEx(hWinXL, 0&, "XLDESK", vbNullString)
    hWin7 = FindWindowEx(hWinDesk, 0&, "EXCEL7", vbNullString)
    If AccessibleObjectFromWindow(hWin7, OBJID_NATIVEOM, iid, obj) = S_OK Then
        Set xlApp = obj.Application
        GetXLapp = True
    End If
End Function
  1. It can be tested using the next test Sub:
Sub testGetExAppColl()
   Dim arr As Variant
   arr = GetExcelAppCollection
   Debug.Print arr(0).Workbooks(1).Name, arr(UBound(arr)).Workbooks.count
End Sub

Please, test it and send some feedback. The code is not so complicated as it can be considered at the first glance... I can simplify it for being used only in 64 bit environment, but I do not think that this can really be an issue.

If something not clear enough, do not hesitate to ask, please.

Edited:

The next function returns all open workbooks (as objects) in a collection. It is similar to the one returning Excel application objects, but it dig a little deeper, extracting all open documents:

Function GetAllWorkbooks() As Collection
    Dim i As Long 
    #If VBA7 Then
        Dim hWinXL As LongPtr
    #Else
        Dim hWinXL As Long
    #End If
    Dim xlApp As Object 'Excel.Application
    Dim wb As Object  ' Excel.Workbook
    Dim dict, k, Col As New Collection
    
    Set dict = CreateObject("scripting.dictionary")
    
    hWinXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
    While hWinXL > 0
        i = i + 1
        If GetXLapp(hWinXL, xlApp) Then
            If Not dict.Exists(xlApp.hWnd) Then
                dict.Add xlApp.hWnd, xlApp
                For Each wb In xlApp.Workbooks
                    Col.Add wb
                Next
            End If
        End If
        hWinXL = FindWindowEx(0, hWinXL, "XLMAIN", vbNullString)
    Wend
    Set GetAllWorkbooks = Col
End Function

In order to test it, you can use the next Sub:

Sub EnumAllOpenWorkbooks()
    Dim Col As Collection, wb As Workbook
    
    Set Col = GetAllWorkbooks()
    For Each wb In Col
        'you can find the one you need
        Debug.Print wb.Name & ":" & _
           IIf(wb.Application.hWnd = Application.hWnd, _
                 "In this instance", "In another instance")
    Next wb
End Sub

Upvotes: 4

Javier Martin Gil
Javier Martin Gil

Reputation: 36

.Net has his own "api-dll" to manage proccess.

Try that and tell me if is useful for you.

For Each p As Process In Process.GetProcesses
    If String.compare(p.ProcessName, "excel",true) = 0 Then
        'Do stuff
        msgbox("hi im a excel process")
    End If
Next

Upvotes: 0

Related Questions