I tested the code shown by Paul. I had 4 Excel instances open, including one hidden.
The big surprise for me was this piece of code:
With xlApps(i)
If .HinstancePtr <> hRunningApp Then
...
Assuming that the xlApps variable contains several different instances, the above condition never meets, because for all xlApps (i) .HinstancePtr = hRunningApp.
I looked at the help and Bill wrote in it:
Application.Hinstance property (Excel)
Returns a handle to the instance of Excel
represented by the Application object.
Since these are different instances, we should get different handles.
That's why I used a different handle - Application.hwnd.
Corrected code that works for me:
Option Explicit
'https://stackoverflow.com/questions/2971473/can-vba-reach-across-instances-of-excel
'http://www.vbaexpress.com/forum/showthread.php?68893-Close-All-Instances-Of-Excel-Without-Saving-Any-Changes
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 hRunningApp As LongPtr '<--to remove
hRunningApp = Application.HinstancePtr '<--to remove
If GetAllExcelInstances(xlApps) Then
Debug.Print String(30, "-")
For i = LBound(xlApps) To UBound(xlApps)
With xlApps(i)
'============= For test only ==============
Debug.Print "Hinstance: " & .HinstancePtr & " | hRunApp:" & hRunningApp 'Application.HinstancePtr
Debug.Print "Found instance.Hwnd: " & .Hwnd & " | This instance.Hwnd: " & Application.Hwnd
Debug.Print "WrkBks.Count: " & .Workbooks.Count
Debug.Print .Caption
Debug.Print "Is visible: " & .Visible
Debug.Print String(30, "-")
'==========================================
If .Hwnd <> Application.Hwnd Then
.DisplayAlerts = False
.Quit
End If
End With
Next i
Debug.Print String(30, "=")
End If
Application.DisplayAlerts = False
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 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
Artik
Reply With Quote
Originally Posted by Paul_Hossler
