'Leith Ross, http://www.vbaexpress.com/forum/showthread.php?60682-application-windows-object
' Written: September 11, 2017
' Author: Leith Ross
' Summary: Searches all open instances of Excel on the user's desktop
' for a workbook matching the given nam. When a match is found
' an object reference to the workbook is returned. If no match
' is found then the value returned is Nothing.
Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0
Type GUID
lData1 As Long
iData2 As Integer
iData3 As Integer
aBData4(0 To 7) As Byte
End Type
Private Declare PtrSafe Function IIDFromString _
Lib "ole32.dll" _
(ByVal lpszIID As String, _
ByRef lpiid As GUID) _
As Long
Private Declare PtrSafe Function FindWindowEx _
Lib "user32.dll" Alias "FindWindowExA" _
(ByVal hWnd1 As LongPtr, _
ByVal hWnd2 As LongPtr, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) _
As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromWindow _
Lib "oleacc.dll" _
(ByVal hwnd As LongPtr, _
ByVal dwId As Long, _
ByRef riid As GUID, _
ByRef ppvObject As Object) _
As Long
Function GetWorkbookByName(ByVal wkbName As String) As Object
Dim CLSID As String
Dim IDisp As GUID
Dim n As Long
Dim ret As Long
Dim xlDesk As LongPtr
Dim xlHwnd As LongPtr
Dim xlWkb As LongPtr
Dim Wnd As Object
Dim Wkb As Workbook
Dim XLapp As Excel.Application
If wkbName = "" Then
MsgBox "Workbook Name Is Missing", vbExclamation
Exit Function
End If
CLSID = StrConv("{00020400-0000-0000-C000-000000000046}", vbUnicode)
ret = IIDFromString(CLSID, IDisp)
Do
xlHwnd = FindWindowEx(0, xlHwnd, "XLMAIN", vbNullString)
If xlHwnd = 0 Then Exit Do
xlDesk = FindWindowEx(xlHwnd, 0&, "XLDESK", vbNullString)
xlWkb = FindWindowEx(xlDesk, 0&, "EXCEL7", vbNullString)
If xlWkb <> 0 Then
ret = AccessibleObjectFromWindow(xlWkb, OBJID_NATIVEOM, IDisp, Wnd)
If ret = 0 Then
Set XLapp = Wnd.Parent.Parent
For n = 1 To XLapp.Workbooks.Count
Set Wkb = XLapp.Workbooks(n)
If Wkb.Name = wkbName Then
Set GetWorkbookByName = Wkb
Exit Function
End If
Next n
End If
End If
Loop
End Function
Sub Collects()
Dim Wkb As Workbook
Set Wkb = GetWorkbookByName("Excel1.xlsx")
If Not Wkb Is Nothing Then
ThisWorkbook.Worksheets("Sheet1").Range("A1").Value = Wkb.Worksheets("Sheet1").Range("A1").Value
End If
End Sub
