1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
| Option Explicit
'https://social.msdn.microsoft.com/Forums/office/en-US/e3e99712-01a7-483e-bf0e-52bb1f94889c/how-to-use-accessibleobjectfromwindow-api-in-vba-to-get-excel-application-object-from-excel?forum=exceldev
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
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
Sub test()
'---------------------------------------------------------------------------------------
' Procedure : test
' Author : Peter Thornton
' Modified : Oliv
' Date : 03/11/2016
' Purpose :
'---------------------------------------------------------------------------------------
'
Dim i As Long
Dim hWinXL As Long
Dim xlApp As Object ' Excel.Application
Dim wb As Object ' Excel.Workbook
hWinXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
While hWinXL > 0
i = i + 1
Debug.Print "Instance_" & i; hWinXL
If GetXLapp(hWinXL, xlApp) Then
Debug.Print "Workbooks count = " & vbTab & xlApp.Workbooks.Count
For Each wb In xlApp.Workbooks
Debug.Print , wb.Name
'Make a change
'wb.activesheet.Range("a1").Value = Time
Next
End If
hWinXL = FindWindowEx(0, hWinXL, "XLMAIN", vbNullString)
Wend
End Sub
'Function GetXLapp(hWinXL As Long, xlApp As Excel.Application) As Boolean
Function GetXLapp(hWinXL As Long, xlApp As Object) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : GetXLapp
' Author : Peter Thornton
' Date : 11/07/2013
' Purpose :
'---------------------------------------------------------------------------------------
'
Dim hWinDesk As Long, hWin7 As Long
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 |