通知バーから発出されるダイアログボックスまで制御してファイルを保存したい
IEまたはIEモードから発出される独自の黄色い通知バーを制御して「名前を付けてファイルを保存する」を実行するマクロを作りました。
個人的にはタブのタイトルで名前つけて保存を実行したいので引数はタブタイトルにしました。
使い方
通知バーが表示されるウィンドウ名を指定して実行する。
この時DownloadFileNotificationBar の引数にFrame Notification Barのハンドルと
ファイル名をフルパスで指定する。
なお、上書き保存には対応していないので注意です。
Option Explicit
Declare Function SendMessage Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hwnd&, _
ByVal wMsg&, _
ByVal wParam&, _
ByVal lParam&) As LongPtr
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias _
"FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) 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 Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
Private Declare PtrSafe Function GetTopWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId 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 Function EnumChildWindows Lib "user32" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam 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 GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As LongPtr) As LongPtr
Private Const WM_COMMAND = &H111&
Private Const WM_SYSCHAR = &H106
Private Const GW_HWNDNEXT = &H2
Private hIES As LongPtr
Public Sub main()
Call download_main("ダウンロード")
End Sub
Private Sub download_main(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
Call DownloadFileNotificationBar(h, ThisWorkbook.Path & "\test.csv")
ie.DocumentElement.Document.Script.setTimeout "javascript:window.close()", 1000
End Sub
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
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
''' 通知バー/Internet Explorerダイアログを操作してファイルをダウンロード
Public Sub DownloadFileNotificationBar(ByVal hIE As Long, ByVal SaveFilePath As String)
''' ファイルを事前に削除
With CreateObject("Scripting.FileSystemObject")
If .FileExists(SaveFilePath) Then .DeleteFile SaveFilePath, True
End With
Dim uiAuto As CUIAutomation: Set uiAuto = New CUIAutomation
''' 通知バーの[別名で保存]を押す
PressSaveAsMenuNotificationBar uiAuto, hIE
''' [名前を付けて保存]ダイアログ操作
SaveAsFileNameDialog uiAuto, SaveFilePath
''' ダウンロード完了後、通知バーを閉じる
ClosingNotificationBar uiAuto, hIE
Set uiAuto = Nothing
End Sub
Private Function PressSaveAsMenuNotificationBar(ByRef uiAuto As CUIAutomation, ByVal ieWnd As Long)
''' 通知バーを取得
Dim hwnd As Long
Dim elmNotificationBar As IUIAutomationElement
Do
DoEvents
Sleep 1&
hwnd = GetDirectUI
Loop Until hwnd
Set elmNotificationBar = uiAuto.ElementFromHandle(ByVal hwnd)
''' [保存] スプリットボタン取得
Dim elmSaveSplitButton As IUIAutomationElement
Do
DoEvents
Sleep 1&
hwnd = GetDirectUI
Do
DoEvents
Sleep 1&
Loop Until IsWindowVisible(hwnd)
Set elmNotificationBar = uiAuto.ElementFromHandle(ByVal hwnd)
Set elmSaveSplitButton = GetElement(uiAuto, elmNotificationBar, UIA_NamePropertyId, "保存", UIA_SplitButtonControlTypeId)
Loop While elmSaveSplitButton Is Nothing
''' [保存] ドロップダウン取得
Const ROLE_SYSTEM_BUTTONDROPDOWN = &H38&
Dim elmSaveDropDownButton As IUIAutomationElement
Do
DoEvents
Sleep 1&
Set elmSaveDropDownButton = GetElement(uiAuto, elmNotificationBar, UIA_LegacyIAccessibleRolePropertyId, ROLE_SYSTEM_BUTTONDROPDOWN, UIA_SplitButtonControlTypeId)
Loop While elmSaveDropDownButton Is Nothing
'''[保存]ドロップダウン押下
Dim iptn As IUIAutomationInvokePattern
Set iptn = elmSaveDropDownButton.GetCurrentPattern(UIA_InvokePatternId)
''' メニューウインドウを取得
Dim elmSaveMenu As IUIAutomationElement
Do
iptn.Invoke
Set elmSaveMenu = GetElement(uiAuto, uiAuto.GetRootElement, UIA_ClassNamePropertyId, "#32768", UIA_MenuControlTypeId)
DoEvents
Sleep 1&
Loop While elmSaveMenu Is Nothing
''' [名前を付けて保存(A)]ボタン押下
Dim hWndSaveMenu As Long
hWndSaveMenu = FindWindow("#32768", vbNullString)
PostMessage hWndSaveMenu, &H106, vbKeyA, 0& ' SYSCHAR=0x106
End Function
Private Function SaveAsFileNameDialog(ByRef uiAuto As CUIAutomation, ByVal SaveFilePath As String)
'''[名前を付けて保存]ダイアログ取得
Dim elmSaveAsWindow As IUIAutomationElement
Do
Set elmSaveAsWindow = GetElement(uiAuto, uiAuto.GetRootElement, UIA_NamePropertyId, "名前を付けて保存", UIA_WindowControlTypeId)
DoEvents
Sleep 1&
Loop While elmSaveAsWindow Is Nothing
'[ファイル名]欄取得 -> ファイルパス入力
Dim elmFileNameEdit As IUIAutomationElement: Set elmFileNameEdit = GetElement(uiAuto, elmSaveAsWindow, UIA_NamePropertyId, "ファイル名:", UIA_EditControlTypeId)
Dim vptn As IUIAutomationValuePattern: Set vptn = elmFileNameEdit.GetCurrentPattern(UIA_ValuePatternId)
vptn.SetValue SaveFilePath
'[保存(S)]ボタン押下
Dim elmSaveButton As IUIAutomationElement
Do
Set elmSaveButton = _
GetElement(uiAuto, elmSaveAsWindow, UIA_NamePropertyId, "保存(S)", UIA_ButtonControlTypeId)
Loop While elmSaveButton Is Nothing
Dim iptn As IUIAutomationInvokePattern: Set iptn = elmSaveButton.GetCurrentPattern(UIA_InvokePatternId)
iptn.Invoke
End Function
Private Function ClosingNotificationBar(ByRef uiAuto As CUIAutomation, ByVal ieWnd As Long)
''' 通知バーを取得
Dim hwnd As Long
Do
DoEvents
Sleep 1&
hwnd = GetDirectUI
Loop Until hwnd
Do
DoEvents
Sleep 1&
Loop Until IsWindowVisible(hwnd)
Dim elmNotificationBar As IUIAutomationElement: Set elmNotificationBar = uiAuto.ElementFromHandle(ByVal hwnd)
''' [通知バーのテキスト]取得
Dim elmNotificationText As IUIAutomationElement
Do
DoEvents
Sleep 1&
Set elmNotificationText = GetElement(uiAuto, elmNotificationBar, UIA_NamePropertyId, "通知バーのテキスト", UIA_TextControlTypeId)
Loop While elmNotificationText Is Nothing
''' [閉じる]ボタン取得
Dim elmCloseButton As IUIAutomationElement
Do
DoEvents
Sleep 1&
Set elmCloseButton = GetElement(uiAuto, elmNotificationBar, UIA_NamePropertyId, "閉じる", UIA_ButtonControlTypeId)
Loop While elmCloseButton Is Nothing
''' [閉じる]ボタン押下
Do
DoEvents
Sleep 1&
Loop Until InStr(elmNotificationText.GetCurrentPropertyValue(UIA_ValueValuePropertyId), "ダウンロードが完了しました") > 0
Dim iptn As IUIAutomationInvokePattern: Set iptn = elmCloseButton.GetCurrentPattern(UIA_InvokePatternId)
iptn.Invoke
End Function
Private Function GetElement(ByVal uiAuto As CUIAutomation, _
ByVal elmParent As IUIAutomationElement, _
ByVal propertyId As Long, _
ByVal propertyValue As Variant, _
Optional ByVal ctrlType As Long = 0) As IUIAutomationElement
Dim cndFirst As IUIAutomationCondition
Dim cndSecond As IUIAutomationCondition
Set cndFirst = uiAuto.CreatePropertyCondition(propertyId, propertyValue)
If ctrlType <> 0 Then
Set cndSecond = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, ctrlType)
Set cndFirst = uiAuto.CreateAndCondition(cndFirst, cndSecond)
End If
Set GetElement = elmParent.FindFirst(TreeScope_Subtree, cndFirst)
End Function