VBA script to close every instance of Excel except itself

Question

I have a subroutine in my errorhandling function that attempts to close every workbook open in every instance of Excel. Otherwise, it might stay in memory and break my next

Answer 1

I know this is an old post but for those who visit here from searches may find it helpful. This code was found and modified. It will give you every SHEET in every WORKBOOK in every INSTANCE. From there you can determine the active instance.

Module..............

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
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long

Type UUID 'GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Code…………………...

Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0

Sub ListAll()
    Dim I As Integer
    Dim hWndMain As Long
    On Error GoTo MyErrorHandler
        hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
        I = 1
        Do While hWndMain <> 0
            Debug.Print "Excel Instance " & I
            GetWbkWindows hWndMain
            hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
            I = I + 1
        Loop
        Exit Sub
    MyErrorHandler:
    MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Sub GetWbkWindows(ByVal hWndMain As Long)
    Dim hWndDesk As Long
    Dim hWnd As Long
    Dim strText As String
    Dim lngRet As Long
    On Error GoTo MyErrorHandler     
        hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
        If hWndDesk <> 0 Then
            hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString) 
            Do While hWnd <> 0
                strText = String$(100, Chr$(0))
                lngRet = GetClassName(hWnd, strText, 100)
                If Left$(strText, lngRet) = "EXCEL7" Then
                    GetExcelObjectFromHwnd hWnd
                    Exit Sub
                End If
                hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
            Loop
            On Error Resume Next
        End If
            Exit Sub
    MyErrorHandler:
        MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub

Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
    Dim fOk As Boolean
    Dim I As Integer
    Dim obj As Object
    Dim iid As UUID
    Dim objApp As Excel.Application
    Dim myWorksheet As Worksheet
    On Error GoTo MyErrorHandler        
        fOk = False
        Call IIDFromString(StrPtr(IID_IDispatch), iid)
        If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
            Set objApp = obj.Application
            For I = 1 To objApp.Workbooks.Count
                Debug.Print "     " & objApp.Workbooks(I).Name
                For Each myWorksheet In objApp.Workbooks(I).Worksheets
                    Debug.Print "          " & myWorksheet.Name
                    DoEvents
                Next
                fOk = True
            Next I
        End If
        GetExcelObjectFromHwnd = fOk
        Exit Function
    MyErrorHandler:
        MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function

I hope this helps someone :)