Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetClassName _
Lib "USER32" _
Alias "GetClassNameA" ( _
ByVal hWnd As LongPtr, _
ByVal lpClassName$, _
ByVal nMaxCount& _
) As Long
Private Declare PtrSafe Function AccessibleObjectFromWindow& _
Lib "oleacc" ( _
ByVal hWnd As LongPtr, _
ByVal dwId As Long, _
riid As GUID, _
xlWB As Object _
)
Private Declare PtrSafe Function EnumWindows& _
Lib "USER32" ( _
ByVal lpEnumFunc As LongPtr, _
ByVal lParam As LongPtr _
)
Private Declare PtrSafe Function EnumChildWindows& _
Lib "USER32" ( _
ByVal hWndParent As LongPtr, _
ByVal lpEnumFunc As LongPtr, _
ByVal lParam As LongPtr _
)
Private Declare PtrSafe Function GetWindowThreadProcessId& _
Lib "USER32" ( _
ByVal hWnd As LongPtr, _
lpdwProcessId& _
)
#Else
Private Declare Function GetClassName& _
Lib "User32" _
Alias "GetClassNameA" ( _
ByVal hWnd&, _
ByVal lpClassName$, _
ByVal nMaxCount& _
)
Private Declare Function AccessibleObjectFromWindow& _
Lib "oleacc" ( _
ByVal hWnd&, _
ByVal dwId&, _
riid As GUID, _
xlWB As Object _
)
Private Declare Function EnumWindows&_
Lib "User32" ( _
ByVal lpEnumFunc&, _
ByVal lParam& _
)
Private Declare Function EnumChildWindows& _
Lib "User32" ( _
ByVal hWndParent&, _
ByVal lpEnumFunc&, _
ByVal lParam& _
)
Private Declare Function GetWindowThreadProcessId& _
Lib "User32" ( _
ByVal hWnd&, _
lpdwProcessId& _
)
#End If
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type param
class As String
dic As Object
pid As Long
End Type
Dim i
Private G As GUID
Function AllWorkbooks()
Dim dic As Object, p As param, WBooks As Variant, WBook As Workbook, arr() As Variant, i&
Set dic = CreateObject("scripting.dictionary")
SetGUID G: p.class = "XLMAIN": Set p.dic = dic: p.pid = 0
EnumWindows AddressOf modEnumWb.WndProc, ByVal VarPtr(p)
For Each WBooks In dic.items
For Each WBook In WBooks.Application.workbooks
ReDim Preserve arr(0 To i)
arr(i) = Array(WBook.FullName, WBook.Application.hWnd)
i = i + 1
Next WBook, WBooks
AllWorkbooks = Application.Index(arr, 0, 0)
Set dic = Nothing
End Function
Private Sub SetGUID(ByRef ID As GUID, Optional VerRus As Boolean = True)
If VerRus Then
With ID
.Data1 = &H20400
.Data2 = &H0
.Data3 = &H0
.Data4(0) = &HC0
.Data4(1) = &H0
.Data4(2) = &H0
.Data4(3) = &H0
.Data4(4) = &H0
.Data4(5) = &H0
.Data4(6) = &H0
.Data4(7) = &H46
End With
Else
With ID
.Data1 = &H90140000
.Data2 = &H16
.Data3 = &H409
.Data4(0) = &H0
.Data4(1) = &H0
.Data4(2) = &H0
.Data4(3) = &H0
.Data4(4) = &H0
.Data4(5) = &HF
.Data4(6) = &HF1
.Data4(7) = &HCE
End With
End If
End Sub
#If VBA7 Then
Private Function WndProc(ByVal hWnd As LongPtr, ByRef lParam As param) As Long
#Else
Private Function WndProc(ByVal hWnd As Long, ByRef lParam As param) As Long
#End If
Select Case lParam.class
Case "XLMAIN"
Dim pid As Long
If ClassName(hWnd) = lParam.class Then
GetWindowThreadProcessId hWnd, pid
If IsEmpty(lParam.dic(pid)) Then
Dim p As param
p.class = "EXCEL7"
Set p.dic = lParam.dic
p.pid = pid
EnumChildWindows hWnd, AddressOf modEnumWb.WndProc, ByVal VarPtr(p)
End If
End If
WndProc = True
Case "EXCEL7"
Dim w As Window, oWb As Workbook, n%
If ClassName(hWnd) = lParam.class Then
AccessibleObjectFromWindow hWnd, -16, G, w
Set lParam.dic(lParam.pid) = w.Application.workbooks
Else
WndProc = True
End If
End Select
DoEvents
End Function
#If VBA7 Then
Function ClassName$(ByVal hWnd As LongPtr)
#Else
Function ClassName$(ByVal hWnd As Long)
#End If
Dim windowClass As String
Dim retVal As LongPtr
windowClass = Space(255)
retVal = GetClassName(hWnd, windowClass, 255)
ClassName = Left$(windowClass, CLng(retVal))
End Function |