【VBA】IEモードで通知バー(Frame Notification Bar)を制御するための関数を書いた

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 追記
通知バーを制御して「ファイルに名前をつけて保存」のダイアログを操作することができました。

今回は以上です。