1. I can't test this since I don't have a multi-instance capability
2. In a single instance, with multiple workbooks open it seems to work
3. I modified the StackOverflow code a bit, so you can blame me if it doesn't work
4. Good luck
edit - miscopied code in original post
Option Explicit
'https://stackoverflow.com/questions/2971473/can-vba-reach-across-instances-of-excel
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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As LongPtr, ByRef lpiid As UUID) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal Hwnd As LongPtr, ByVal dwId As LongPtr, ByRef riid As UUID, ByRef ppvObject As Object) As LongPtr
Type UUID 'GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As LongPtr = &HFFFFFFF0
' Run as entry point of example
Sub CloseAllWorkbooksWithoutSaving()
Dim i As Long
Dim xlApps() As Application
Dim wb As Workbook
Dim hRunningApp As LongPtr
hRunningApp = Application.HinstancePtr
If GetAllExcelInstances(xlApps) Then
For i = LBound(xlApps) To UBound(xlApps)
With xlApps(i)
If .HinstancePtr <> hRunningApp Then
For Each wb In .Workbooks
wb.Close SaveChanges:=False
Next
.ActiveWorkbook.Saved = True
.Quit
End If
End With
Next
End If
For Each wb In Application.Workbooks
If Not wb Is ThisWorkbook Then wb.Close SaveChanges:=False
Next
Application.ActiveWorkbook.Saved = True
Application.Quit
End Sub
' Actual public facing function to be called in other code
Public Function GetAllExcelInstances(xlApps() As Application) As Long
Dim n As Long
Dim app As Application
Dim hWndMain As LongPtr
On Error GoTo MyErrorHandler
' Cater for 100 potential Excel instances, clearly could be better
ReDim xlApps(1 To 100)
hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
Do While hWndMain <> 0
Set app = GetExcelObjectFromHwnd(hWndMain)
If Not (app Is Nothing) Then
If n = 0 Then
n = n + 1
Set xlApps(n) = app
ElseIf checkHwnds(xlApps, app.Hwnd) Then
n = n + 1
Set xlApps(n) = app
End If
End If
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop
If n Then
ReDim Preserve xlApps(1 To n)
GetAllExcelInstances = n
Else
Erase xlApps
End If
Exit Function
MyErrorHandler:
MsgBox "GetAllExcelInstances" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function
Private Function checkHwnds(xlApps() As Application, Hwnd As LongPtr) As Boolean
Dim i As Integer
For i = LBound(xlApps) To UBound(xlApps)
If xlApps(i).Hwnd = Hwnd Then
checkHwnds = False
Exit Function
End If
Next i
checkHwnds = True
End Function
Private Function GetExcelObjectFromHwnd(ByVal hWndMain As LongPtr) As Application
Dim hWndDesk As LongPtr
Dim Hwnd As LongPtr
Dim strText As String
Dim lngRet As Long
Dim iid As UUID
Dim obj As Object
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 = CLng(GetClassName(Hwnd, strText, 100))
If Left$(strText, lngRet) = "EXCEL7" Then
Call IIDFromString(StrPtr(IID_IDispatch), iid)
If AccessibleObjectFromWindow(Hwnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
Set GetExcelObjectFromHwnd = obj.Application
Exit Function
End If
End If
Hwnd = FindWindowEx(hWndDesk, Hwnd, vbNullString, vbNullString)
Loop
On Error Resume Next
End If
Exit Function
MyErrorHandler:
MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function