teratail
回答率
85.47%
質問するログイン新規登録
トップVBAに関する質問Windows Excel [最近つかったもの] を取得したいです

編集履歴

回答編集履歴

4

改善

2018/10/06 07:32

投稿

退会済みユーザー
test CHANGED
@@ -300,11 +300,11 @@
300
300
 
301
301
  Dim i As Long
302
302
 
303
- Dim DicApp As Dictionary
303
+ Dim DicApp As Dictionary
304
-
304
+
305
- Dim Key As Variant
305
+ Dim Key As Variant
306
-
306
+
307
- Dim Apps() As Excel.Application
307
+ Dim Apps() As Excel.Application
308
308
 
309
309
 
310
310
 

3

ミス修正

2018/10/06 07:32

投稿

退会済みユーザー
test CHANGED
@@ -142,7 +142,7 @@
142
142
 
143
143
  ' コールバック関数
144
144
 
145
- Public Function EnumWindowsProc(ByVal hWnd As Long, _
145
+ Private Function EnumWindowsProc(ByVal hWnd As Long, _
146
146
 
147
147
  ByVal lParam As Long) As Long
148
148
 

2

ミス修正

2018/10/06 07:31

投稿

退会済みユーザー
test CHANGED
@@ -312,6 +312,8 @@
312
312
 
313
313
 
314
314
 
315
+ Erase wD
316
+
315
317
  lngRtnCode = EnumWindows(AddressOf EnumWindowsProc, ByVal 0&)
316
318
 
317
319
  For i = 0 To UBound(wD)

1

追記

2018/10/06 07:28

投稿

退会済みユーザー
test CHANGED
@@ -6,6 +6,8 @@
6
6
 
7
7
 
8
8
 
9
+ ### エクセルが1つしか起動していない場合
10
+
9
11
  ```VBA
10
12
 
11
13
  '起動中のエクセルのアクティブブック名を返す関数の例
@@ -35,3 +37,337 @@
35
37
  End Function
36
38
 
37
39
  ```
40
+
41
+
42
+
43
+ ### 複数のエクセルプロセスに対応する場合
44
+
45
+ モジュール側（適当なモジュール名で保存）
46
+
47
+ ```VBA
48
+
49
+ Option Explicit
50
+
51
+
52
+
53
+ Private Declare Function EnumWindows Lib "user32.dll" _
54
+
55
+ (ByVal lpEnumFunc As Long, _
56
+
57
+ ByVal lParam As Long) As Long
58
+
59
+ Private Declare Function GetClassName Lib "user32.dll" _
60
+
61
+ Alias "GetClassNameA" _
62
+
63
+ (ByVal hWnd As Long, _
64
+
65
+ ByVal lpClassName As String, _
66
+
67
+ ByVal nMaxCount As Long) As Long
68
+
69
+ Private Declare Function EnumChildWindows Lib "user32.dll" _
70
+
71
+ (ByVal hWndParent As Long, _
72
+
73
+ ByVal lpEnumFunc As Long, _
74
+
75
+ ByVal lParam As Long) As Long
76
+
77
+ Private Declare Function GetWindowText Lib "user32.dll" _
78
+
79
+ Alias "GetWindowTextA" _
80
+
81
+ (ByVal hWnd As Long, _
82
+
83
+ ByVal lpString As String, _
84
+
85
+ ByVal nMaxCount As Long) As Long
86
+
87
+ Private Declare Function SendMessage Lib "user32" _
88
+
89
+ Alias "SendMessageA" _
90
+
91
+ (ByVal hWnd As Long, ByVal Msg As Long, _
92
+
93
+ ByVal wParam As Long, lParam As Any) As Long
94
+
95
+ Private Declare Function IIDFromString Lib "ole32" _
96
+
97
+ (lpsz As Any, lpiid As Any) As Long
98
+
99
+ Private Declare Function ObjectFromLresult Lib "oleacc" _
100
+
101
+ (ByVal lResult As Long, riid As Any, _
102
+
103
+ ByVal wParam As Long, ppvObject As Any) As Long
104
+
105
+ Private Declare Function IsWindow Lib "user32" _
106
+
107
+ (ByVal hWnd As Long) As Long
108
+
109
+ Private Const OBJID_NATIVEOM = &HFFFFFFF0
110
+
111
+ Private Const OBJID_CLIENT = &HFFFFFFFC
112
+
113
+
114
+
115
+ Private Const IID_IMdcList = "{8BD21D23-EC42-11CE-9E0D-00AA006002F3}"
116
+
117
+ Private Const IID_IUnknown = "{00000000-0000-0000-C000-000000000046}"
118
+
119
+ Private Const IID_IDispatch = "{00020400-0000-0000-C000-000000000046}"
120
+
121
+
122
+
123
+ Private Const WM_GETOBJECT = &H3D&
124
+
125
+
126
+
127
+ Private Type WbkDtl
128
+
129
+ hWndAp As Long
130
+
131
+ hWndWb As Long
132
+
133
+ xlAP As Excel.Application
134
+
135
+ xlWB As Excel.Workbook
136
+
137
+ End Type
138
+
139
+ Private wD() As WbkDtl
140
+
141
+
142
+
143
+ ' コールバック関数
144
+
145
+ Public Function EnumWindowsProc(ByVal hWnd As Long, _
146
+
147
+ ByVal lParam As Long) As Long
148
+
149
+
150
+
151
+ Dim strClassBuff As String * 128
152
+
153
+ Dim strClass As String
154
+
155
+ Dim lngRtnCode As Long
156
+
157
+ Dim lngThreadId As Long
158
+
159
+ Dim lngProcesID As Long
160
+
161
+
162
+
163
+ ' クラス名取得
164
+
165
+ lngRtnCode = GetClassName(hWnd, strClassBuff, Len(strClassBuff))
166
+
167
+ strClass = Left(strClassBuff, InStr(strClassBuff, vbNullChar) - 1)
168
+
169
+ If strClass = "XLMAIN" Then
170
+
171
+ ' 子ウィンドウを列挙
172
+
173
+ lngRtnCode = EnumChildWindows(hWnd, _
174
+
175
+ AddressOf EnumChildSubProc, lParam)
176
+
177
+ End If
178
+
179
+ ' 列挙を継続
180
+
181
+ EnumPass:
182
+
183
+ EnumWindowsProc = True
184
+
185
+ End Function
186
+
187
+
188
+
189
+ ' コールバック関数 - 子ウィンドウを列挙
190
+
191
+ Private Function EnumChildSubProc(ByVal hwndChild As Long, _
192
+
193
+ ByVal lParam As Long) As Long
194
+
195
+ Dim strClassBuff As String * 128
196
+
197
+ Dim strClass As String
198
+
199
+ Dim strTextBuff As String * 516
200
+
201
+ Dim strText As String
202
+
203
+ Dim lngRtnCode As Long
204
+
205
+
206
+
207
+ ' クラス名取得
208
+
209
+ lngRtnCode = GetClassName(hwndChild, strClassBuff, Len(strClassBuff))
210
+
211
+ strClass = Left(strClassBuff, InStr(strClassBuff, vbNullChar) - 1)
212
+
213
+ If strClass = "EXCEL7" Then
214
+
215
+ ' テキストをバッファに
216
+
217
+ lngRtnCode = GetWindowText(hwndChild, strTextBuff, Len(strTextBuff))
218
+
219
+ strText = Left(strTextBuff, InStr(strTextBuff, vbNullChar) - 1)
220
+
221
+
222
+
223
+ If InStr(1, strText, ".xla") = 0 Then '
224
+
225
+ If Sgn(wD) = 0 Then
226
+
227
+ ReDim wD(0)
228
+
229
+ wD(0).hWndWb = hwndChild
230
+
231
+ Else
232
+
233
+ ReDim Preserve wD(UBound(wD) + 1)
234
+
235
+ wD(UBound(wD)).hWndWb = hwndChild
236
+
237
+ End If
238
+
239
+ End If
240
+
241
+ End If
242
+
243
+ ' 列挙を継続
244
+
245
+ EnumChildPass:
246
+
247
+ EnumChildSubProc = True
248
+
249
+ End Function
250
+
251
+
252
+
253
+ Private Sub GetExcelBook(wDl As WbkDtl)
254
+
255
+ Dim IID(0 To 3) As Long
256
+
257
+ Dim bytID() As Byte
258
+
259
+ Dim lngResult As Long
260
+
261
+ Dim lngRtnCode As Long
262
+
263
+ Dim wbw As Excel.Window
264
+
265
+
266
+
267
+ If IsWindow(wDl.hWndWb) = 0 Then Exit Sub
268
+
269
+ lngResult = SendMessage(wDl.hWndWb, WM_GETOBJECT, 0, ByVal OBJID_NATIVEOM)
270
+
271
+ If lngResult Then
272
+
273
+ bytID = IID_IDispatch & vbNullChar
274
+
275
+ IIDFromString bytID(0), IID(0)
276
+
277
+ lngRtnCode = ObjectFromLresult(lngResult, IID(0), 0, wbw)
278
+
279
+ If Not wbw Is Nothing Then
280
+
281
+ Set wDl.xlWB = wbw.Parent
282
+
283
+ Set wDl.xlAP = wbw.Application
284
+
285
+ wDl.hWndAp = wbw.Application.hWnd
286
+
287
+ End If
288
+
289
+ End If
290
+
291
+ End Sub
292
+
293
+
294
+
295
+ '起動中のエクセルのApplicationオブジェクトの配列を返す
296
+
297
+ Public Function GetExcelApplications() As Variant
298
+
299
+ Dim lngRtnCode As Long
300
+
301
+ Dim i As Long
302
+
303
+ Dim DicApp As Dictionary
304
+
305
+ Dim Key As Variant
306
+
307
+ Dim Apps() As Excel.Application
308
+
309
+
310
+
311
+ Set DicApp = New Dictionary
312
+
313
+
314
+
315
+ lngRtnCode = EnumWindows(AddressOf EnumWindowsProc, ByVal 0&)
316
+
317
+ For i = 0 To UBound(wD)
318
+
319
+ Call GetExcelBook(wD(i))
320
+
321
+ If Not DicApp.Exists(wD(i).hWndAp) Then
322
+
323
+ DicApp.Add wD(i).hWndAp, wD(i).xlAP
324
+
325
+ End If
326
+
327
+ Next
328
+
329
+
330
+
331
+ If DicApp.Count > 0 Then
332
+
333
+ ReDim Apps(1 To DicApp.Count)
334
+
335
+ i = 0
336
+
337
+ For Each Key In DicApp.Keys
338
+
339
+ i = i + 1
340
+
341
+ Set Apps(i) = DicApp(Key)
342
+
343
+ Next
344
+
345
+ End If
346
+
347
+
348
+
349
+ GetExcelApplications = Apps
350
+
351
+ End Function
352
+
353
+ ```
354
+
355
+ 呼び出し側（任意のモジュールに記載）
356
+
357
+ ```VBA
358
+
359
+ 'Excel Applicationごとのアクティブワークブックの名前をイミディエイトウィンドウに出力
360
+
361
+ Sub Test_ExcelApps()
362
+
363
+ Dim App As Variant
364
+
365
+ For Each App In GetExcelApplications
366
+
367
+ Debug.Print App.ActiveWorkbook.Name
368
+
369
+ Next
370
+
371
+ End Sub
372
+
373
+ ```