URL /
Comment
'-------------------------------------------------------------------------------
'■起動中のExcelインスタンスをコレクションとして返してくれる関数
'
'引用元
'park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200809/08090125.txt
'コーダ：shiraさま
'紹介者：arajinさま
'-------------------------------------------------------------------------------
'-----↓引用ココカラ↓--------------------------------------
Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _
(ByVal hWnd As Long, ByVal dwId As Long, _
riid As Any, ppvObject As Any) As Long
Const OBJID_NATIVEOM = &HFFFFFFF0
Private Declare Function CoRegisterMessageFilter Lib "ole32" _
(ByVal lpMessageFilter As Any, _
lplpMessageFilter As Any) As Long
' ブック(アドイン含む)を1つ以上開いているExcel.Applicationを列挙
Private Function EnumExcelApps( _
Optional ByVal SkipIfRejected As Boolean) As Collection
Dim IID_IDispatch As GUID
Dim pPrevFilter As IUnknown 'IMessageFilter
Dim coll As Collection
Dim objWindow As Object
Dim hwndApp As Long
Dim hwndClient As Long
Dim hwndBook As Long
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
Set coll = New Collection
If SkipIfRejected Then
CoRegisterMessageFilter Nothing, pPrevFilter
End If
Do
hwndApp = FindWindowEx(0, hwndApp, "XLMAIN", vbNullString)
If hwndApp = 0 Then Exit Do
hwndClient = FindWindowEx(hwndApp, 0, "XLDESK", vbNullString)
If hwndClient Then
hwndBook = FindWindowEx(hwndClient, 0, "EXCEL7", vbNullString)
If hwndBook Then
AccessibleObjectFromWindow hwndBook, OBJID_NATIVEOM, _
IID_IDispatch, objWindow
If Not objWindow Is Nothing Then
On Error Resume Next
coll.Add objWindow.Application
On Error GoTo 0
Set objWindow = Nothing
End If
End If
End If
Loop
If Not pPrevFilter Is Nothing Then
CoRegisterMessageFilter pPrevFilter, ByVal Nothing
End If
Set EnumExcelApps = coll
End Function
'-----↑引用ココマデ↑--------------------------------------
'-------------------------------------------------------------------------------
URL /
Comment
'---------------------------------------
'■EnumExcelApps_inf テストコード
'
'起動中のExcelを回して
'各インスタンス毎のWorkbooks.Count，
'各WorkbookのFullNameを表示する
Sub test()
Dim xlApp As Application
Dim myWbk As Workbook
For Each xlApp In EnumExcelApps_inf
Debug.Print xlApp.Workbooks.Count
For Each myWbk In xlApp.Workbooks
Debug.Print myWbk.FullName
Next myWbk
Next xlApp
End Sub
'---------------------------------------
URL /
Comment
'-------------------------------------------------------------------------------
'■起動中のExcelインスタンスをコレクションとして返す関数(劣化版)
'
'元コード
'park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200809/08090125.txt
'コーダ：shiraさま
'紹介者：arajinさま
'
'劣化：_Kyle(1291004)
' ・関数をPublicに変更
' ・レイアウト変更
'-------------------------------------------------------------------------------
'-----↓劣化コードココカラ↓--------------------------------
Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hwndParent As Long, _
ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, _
ByVal lpszWindow As String _
) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hWnd As Long, _
ByVal dwId As Long, _
riid As Any, _
ppvObject As Any _
) As Long
Const OBJID_NATIVEOM = &HFFFFFFF0
Private Declare Function CoRegisterMessageFilter Lib "ole32" ( _
ByVal lpMessageFilter As Any, _
lplpMessageFilter As Any _
) As Long
'-------------------------------------------------
' ブック(アドイン含む)を1つ以上開いているExcel.Applicationを列挙
Public Function EnumExcelApps_inf( _
Optional ByVal SkipIfRejected As Boolean _
) As Collection
Dim IID_IDispatch As GUID
Dim pPrevFilter As IUnknown 'IMessageFilter
Dim coll As Collection
Dim objWindow As Object
Dim hwndApp As Long
Dim hwndClient As Long
Dim hwndBook As Long
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
Set coll = New Collection
If SkipIfRejected Then
CoRegisterMessageFilter Nothing, pPrevFilter
End If
Do
hwndApp = FindWindowEx(0, hwndApp, "XLMAIN", vbNullString)
If hwndApp = 0 Then Exit Do
hwndClient = FindWindowEx(hwndApp, 0, "XLDESK", vbNullString)
If hwndClient Then
hwndBook = FindWindowEx(hwndClient, 0, "EXCEL7", vbNullString)
If hwndBook Then
AccessibleObjectFromWindow _
hwndBook, OBJID_NATIVEOM, IID_IDispatch, objWindow
If Not objWindow Is Nothing Then
On Error Resume Next
coll.Add objWindow.Application
On Error GoTo 0
Set objWindow = Nothing
End If
End If
End If
Loop
If Not pPrevFilter Is Nothing Then
CoRegisterMessageFilter pPrevFilter, ByVal Nothing
End If
Set EnumExcelApps_inf = coll
End Function
'-----↑劣化コードココマデ↑--------------------------------
'-------------------------------------------------------------------------------