IEモードの通知バーを制御したい
IEモードでも昔ながらの通知バーを制御したい
IEでよく使っていたあの黄色い通知バーを制御するVBAコードを書きました。
使い方としては通知バーが表示されるウィンドウのタイトルを渡すだけでOKです。
' 通知バーが表示されるウィンドウ名がダウンロードのとき
Private Sub FrameNotificationBarActionTest()
Call FrameNotificationBarAction("ダウンロード")
End Sub
以下、モジュールに書くコードです。
' Option Compare Database
Option Explicit
Private Declare PtrSafe Function GetTopWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As LongPtr) As LongPtr
Private Declare PtrSafe Function EnumChildWindows Lib "user32" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As LongPtr) As LongPtr
Private Declare PtrSafe Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As LongPtr, ByVal msg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr, ByVal fuFlags As LongPtr, ByVal uTimeout As LongPtr, lpdwResult As LongPtr) As LongPtr
Private Declare PtrSafe Function IIDFromString Lib "ole32" (lpsz As Any, lpiid As Any) As Long
Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, riid As Any, ByVal wParam As LongPtr, ppvObject As Object) As LongPtr
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Const WM_COMMAND = &H111&
Private Const WM_SYSCHAR = &H106
Private Const GW_HWNDNEXT = &H2
Private hIES As LongPtr
Private Sub FrameNotificationBarActionTest()
Call FrameNotificationBarAction("ダウンロード")
End Sub
Public Sub FrameNotificationBarAction(title As String)
Dim ie As Object
Dim hDlg As LongPtr
Dim hWndIE As LongPtr
Dim h As LongPtr
Do
Set ie = GetWindow(title)
Loop Until Not (ie Is Nothing)
h = 0
Do
DoEvents
Sleep 1&
h = GetDirectUI
Loop Until h
'通知バー表示待ち
Do
DoEvents
Sleep 500&
Loop Until IsWindowVisible(h)
PostMessage h, WM_SYSCHAR, Asc("S"), 0
Sleep 500&
'通知バー表示待ち
Do
DoEvents
Sleep 500&
h = GetDirectUI
Loop Until h
Do
DoEvents
Sleep 500&
Loop Until IsWindowVisible(h)
ie.DocumentElement.Document.Script.setTimeout "javascript:window.close()", 0
End Sub
Private Function GetDirectUI() As LongPtr
Dim con As Object
Dim items As Object
Dim HtmlDoc As Object
Dim hwnd As LongPtr: hwnd = 0
Dim pid As LongPtr: pid = 0
Dim buf As String * 255
Dim ClassName As String
Const ProcessName = "msedge.exe"
Set con = CreateObject("WbemScripting.SWbemLocator").ConnectServer
hwnd = GetTopWindow(0)
Do
GetClassName hwnd, buf, Len(buf)
ClassName = Left(buf, InStr(buf, vbNullChar) - 1)
If InStr(ClassName, "Chrome_WidgetWin_") > 0 Then
'ウィンドウハンドルからプロセスIDを取得し、Edgeのウィンドウかどうかを判別する
GetWindowThreadProcessId hwnd, pid
Set items = con.ExecQuery("Select ProcessId From Win32_Process Where (ProcessId = '" & pid & "') And (Name = '" & ProcessName & "')")
If items.Count > 0 Then
'Edgeの子ウィンドウ列挙
EnumChildWindows hwnd, AddressOf EnumChildProcDirectUI, 0
If hIES <> 0 Then
GetDirectUI = hIES
Exit Do
End If
End If
End If
hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)
Loop While hwnd <> 0
End Function
Private Function EnumChildProcDirectUI(ByVal hwnd As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim buf As String * 255
Dim ClassName As String
GetClassName hwnd, buf, Len(buf)
ClassName = Left(buf, InStr(buf, vbNullChar) - 1)
If ClassName = "Frame Notification Bar" Then
hIES = hwnd
EnumChildProcDirectUI = False
Exit Function
End If
EnumChildProcDirectUI = True
End Function
Private Function GetWindow(title As String) As Object
Dim con As Object
Dim items As Object
Dim HtmlDoc As Object
Dim hwnd As LongPtr: hwnd = 0
Dim pid As LongPtr: pid = 0
Dim buf As String * 255
Dim ClassName As String
Const ProcessName = "msedge.exe"
Set con = CreateObject("WbemScripting.SWbemLocator").ConnectServer
hwnd = GetTopWindow(0)
Do
GetClassName hwnd, buf, Len(buf)
ClassName = Left(buf, InStr(buf, vbNullChar) - 1)
If InStr(ClassName, "Chrome_WidgetWin_") > 0 Then
'ウィンドウハンドルからプロセスIDを取得し、Edgeのウィンドウかどうかを判別する
GetWindowThreadProcessId hwnd, pid
Set items = con.ExecQuery("Select ProcessId From Win32_Process Where (ProcessId = '" & pid & "') And (Name = '" & ProcessName & "')")
If items.Count > 0 Then
'Edgeの子ウィンドウ列挙
EnumChildWindows hwnd, AddressOf EnumChildProcIES, 0
If hIES <> 0 Then
Set HtmlDoc = GetHTMLDocumentFromIES(hIES)
If HtmlDoc Is Nothing Then
Else
If InStr(HtmlDoc.title, title) > 0 Then
Set GetWindow = HtmlDoc
Exit Do
End If
End If
End If
End If
End If
hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)
Loop While hwnd <> 0
End Function
Private Function EnumChildProcIES(ByVal hwnd As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim buf As String * 255
Dim ClassName As String
GetClassName hwnd, buf, Len(buf)
ClassName = Left(buf, InStr(buf, vbNullChar) - 1)
If ClassName = "Internet Explorer_Server" Then
hIES = hwnd
EnumChildProcIES = False
Exit Function
End If
EnumChildProcIES = True
End Function
Private Function GetHTMLDocumentFromIES(ByVal hwnd As LongPtr) As Object
Dim msg As LongPtr, res As LongPtr
Dim iid(0 To 3) As LongPtr
Dim ret As Object, obj As Object
Const SMTO_ABORTIFHUNG = &H2
Const IID_IHTMLDocument2 = "{332c4425-26cb-11d0-b483-00c04fd90119}"
Set ret = Nothing '初期化
msg = RegisterWindowMessage("WM_HTML_GETOBJECT")
SendMessageTimeout hwnd, msg, 0, 0, SMTO_ABORTIFHUNG, 1000, res
If res Then
IIDFromString StrPtr(IID_IHTMLDocument2), iid(0)
If ObjectFromLresult(res, iid(0), 0, obj) = 0 Then Set ret = obj
End If
Set GetHTMLDocumentFromIES = ret
End Function
AccessVBAを利用している場合は冒頭のOption Compare Databaseのコメントアウトをはずしてください。
できれば名前を付けて保存もやってみたかったのですが、うまくいかなかったので
とりあえずはダウンロードフォルダ運用で良いかなって感じです。
ダウンロードフォルダに置いたらFileSystemObject や Dir関数でコピーとか判定とかすれば
「ファイルに名前をつけて保存」のダイアログを操作する必要もないだろうな思うところです。
2022.06.24 追記
通知バーを制御して「ファイルに名前をつけて保存」のダイアログを操作することができました。
今回は以上です。