Option Explicit
Private Declare Function GetRunningObjectTable Lib "ole32.dll" (ByVal dwReserved As Long, pROT As Long) As Long
Private Declare Function CreateBindCtx Lib "ole32.dll" (ByVal dwReserved As Long, pBindCtx As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Sub OleInitialize Lib "ole32.dll" (pvReserved As Any)
Private Declare Sub OleUninitialize Lib "ole32.dll" ()
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _
ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Private Declare Function PutMem2 Lib "msvbvm60" (ByVal pWORDDst As Long, ByVal NewValue As Long) As Long
Private Declare Function PutMem4 Lib "msvbvm60" (ByVal pDWORDDst As Long, ByVal NewValue As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (ByVal pDWORDSrc As Long, ByVal pDWORDDst As Long) As Long
Private Declare Function VarPtr Lib "msvbvm60" (var As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function CopyStringA Lib "kernel32" Alias "lstrcpyA" (ByVal NewString As String, ByVal OldString As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, _
lpWideCharStr As Any, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, _
ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Const GMEM_FIXED As Long = &H0
Private Const asmPUSH_imm32 As Byte = &H68
Private Const asmRET_imm16 As Byte = &HC2
Private Const asmRET_16 As Long = &H10C2&
Private Const asmCALL_rel32 As Byte = &HE8
'IUnknown vTable ordinals
Private Const unk_QueryInterface As Long = 0
Private Const unk_AddRef As Long = 1
Private Const unk_Release As Long = 2
Private Const vtbl_ROT_EnumRunning = 9
Private Const vtbl_EnumMoniker_Next = 3
Private Const vtbl_Moniker_GetDisplayName = 20
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Sub Example()
Dim AllExcelApps As Collection, ExcelApp As Application, wb As Workbook, Pid As Long
Set AllExcelApps = GetAllInstances
If Not AllExcelApps Is Nothing Then
For Each ExcelApp In AllExcelApps
GetWindowThreadProcessId ExcelApp.hwnd, Pid
Debug.Print ExcelApp.Caption & ", Process ID = " & Pid
For Each wb In ExcelApp.Workbooks
Debug.Print " " & wb.Name
Next
Next
End If
End Sub
'Function to call Interface members by ordinal in VTable
Private Function CallInterface(ByVal pInterface As Long, ByVal FuncOrdinal As Long, _
ByVal ParamsCount As Long, Optional ByVal p1 As Long = 0, Optional ByVal p2 As Long = 0, _
Optional ByVal p3 As Long = 0, Optional ByVal p4 As Long = 0, Optional ByVal p5 As Long = 0, _
Optional ByVal p6 As Long = 0, Optional ByVal p7 As Long = 0, Optional ByVal p8 As Long = 0, _
Optional ByVal p9 As Long = 0, Optional ByVal p10 As Long = 0) As Long
Dim i As Long, t As Long
Dim hGlobal As Long, hGlobalOffset As Long
If ParamsCount < 0 Then Err.Raise 5 'invalid call
If pInterface = 0 Then Err.Raise 5
'5 bytes for each parameter
'5 bytes - PUSH this
'5 bytes - call member function
'3 bytes - ret 0x0010, pop CallWindowProc
'1 byte - dword align.
hGlobal = GlobalAlloc(GMEM_FIXED, 5 * ParamsCount + 5 + 5 + 3 + 1)
If hGlobal = 0 Then Err.Raise 7 'insuff. memory
hGlobalOffset = hGlobal
If ParamsCount > 0 Then
t = VarPtr(p1)
For i = ParamsCount - 1 To 0 Step -1
PutMem2 hGlobalOffset, asmPUSH_imm32
hGlobalOffset = hGlobalOffset + 1
GetMem4 t + i * 4, hGlobalOffset
hGlobalOffset = hGlobalOffset + 4
Next
End If
'First member of any interface - this. Assign...
PutMem2 hGlobalOffset, asmPUSH_imm32
hGlobalOffset = hGlobalOffset + 1
PutMem4 hGlobalOffset, pInterface
hGlobalOffset = hGlobalOffset + 4
'Call IFace Function by its ordinal
PutMem2 hGlobalOffset, asmCALL_rel32
hGlobalOffset = hGlobalOffset + 1
GetMem4 pInterface, VarPtr(t) 'dereference: find vTable
GetMem4 t + FuncOrdinal * 4, VarPtr(t) 'Function offset in vTable, dereference
PutMem4 hGlobalOffset, t - hGlobalOffset - 4
hGlobalOffset = hGlobalOffset + 4
'all interfaces are stdcall, so forget about stack clearing
PutMem4 hGlobalOffset, asmRET_16 'ret 0x0010
CallInterface = CallWindowProc(hGlobal, 0, 0, 0, 0)
GlobalFree hGlobal
End Function
Private Function StrFromPtrA(ByVal lpszA As Long, Optional nSize As Long = 0) As String
Dim s As String, bTrim As Boolean
If nSize = 0 Then
nSize = lstrlenA(lpszA)
bTrim = True
End If
s = String(nSize, Chr$(0))
CopyStringA s, ByVal lpszA
If bTrim Then s = TrimNULL(s)
StrFromPtrA = s
End Function
Private Function StrFromPtrW(ByVal lpszW As Long, Optional nSize As Long = 0) As String
Dim s As String, bTrim As Boolean
If nSize = 0 Then
nSize = lstrlenW(lpszW) * 2
bTrim = True
End If
s = String(nSize, Chr$(0))
' CopyMemory ByVal StrPtr(s), ByVal lpszW, nSize ' VBA doesn't support StrPtr
WideCharToMultiByte 0, &H0, ByVal lpszW, -1, ByVal s, Len(s), &H0, &H0
If bTrim Then s = TrimNULL(s)
StrFromPtrW = s
End Function
Private Function TrimNULL(ByVal str As String) As String
If InStr(str, Chr$(0)) > 0& Then
TrimNULL = Left$(str, InStr(str, Chr$(0)) - 1&)
Else
TrimNULL = str
End If
End Function
Public Function GetAllInstances() As Collection
Dim pROT As Long, pEnumMoniker As Long, pMoniker As Long, pBindCtx As Long
Dim ret As Long, nCount As Long, CheckForInstance As Boolean, Key As String
Dim pName As Long, RegisteredName As String, ExcelApp As Application
ret = GetRunningObjectTable(0, pROT)
ret = CreateBindCtx(0, pBindCtx)
CallInterface pROT, vtbl_ROT_EnumRunning, 1, VarPtr(pEnumMoniker)
While CallInterface(pEnumMoniker, vtbl_EnumMoniker_Next, 3, 1, VarPtr(pMoniker), VarPtr(nCount)) = 0
CallInterface pMoniker, vtbl_Moniker_GetDisplayName, 3, pBindCtx, 0, VarPtr(pName)
'For win9x you'll need StrFromPtrA
RegisteredName = StrFromPtrW(pName)
If InStr(LCase(RegisteredName), "book") Then
CheckForInstance = True
Else
Select Case Right(RegisteredName, 3)
Case "xla", "slk", "dif", "csv", "txt", "prn", "dbf", "wq1", "wks", "wk1", "wk3", "wk4", "xlw", "xls", "xlt", "htm", "mht", "xml"
CheckForInstance = True
End Select
Select Case Right(RegisteredName, 5)
Case ".html", "mhtml"
CheckForInstance = True
End Select
End If
If CheckForInstance Then
CheckForInstance = False
If ParentIsExcel(RegisteredName, ExcelApp) Then
If GetAllInstances Is Nothing Then Set GetAllInstances = New Collection
Key = CStr(ObjPtr(ExcelApp))
If Not InstanceAlreadyCollected(GetAllInstances, Key) Then
GetAllInstances.Add ExcelApp, Key
End If
End If
End If
CallInterface pMoniker, unk_Release, 0
CoTaskMemFree pName
Wend
CallInterface pEnumMoniker, unk_Release, 0
CallInterface pBindCtx, unk_Release, 0
CallInterface pROT, unk_Release, 0
Exit Function
End Function
Private Function ParentIsExcel(ByVal RegisteredName As String, ExcelApp As Application) As Boolean
On Error Resume Next
Set ExcelApp = GetObject(RegisteredName).Parent
If ExcelApp.Name = "Microsoft Excel" Then
ParentIsExcel = True
End If
End Function
Private Function InstanceAlreadyCollected(GetAllInstances As Collection, Key As String) As Boolean
On Error GoTo Err_InstanceAlreadyCollected
Dim o As Application
Set o = GetAllInstances(Key)
InstanceAlreadyCollected = True
Err_InstanceAlreadyCollected:
End Function |
