VBA通过自定义函数实现IE下载提示“保存”按钮点击，替代SendKeys

当前开发进度 #

• 已实现VBA子过程自动从IE浏览器拉取表格文件的核心流程
• 已移除流程中所有其他SendKeys操作，仅剩余下载提示弹窗的“保存”按钮点击环节无法自动化
• 已检索公开社区相关主题内容，获取一套参考实现的自定义函数，但始终无法完成适配、正常运行

场景特殊约束 #

目标URL无法通过携带参数的方式直接触发下载，需要先在IE页面填写信息、点击Excel按钮，才会弹出表格下载提示。
已分别测试两种下载触发形式：可通过CTRL+J调出的完整下载窗口、浏览器底部常驻下载提示栏，两种场景下现有代码均运行失败。
调出完整下载窗口的操作本身需要依赖SendKeys，而本次开发要求完全移除SendKeys操作依赖；代码运行时默认仅触发浏览器底部的下载提示栏。

现有代码实现 #

独立模块自定义函数 #

#If VBA7 Then
'Code is running VBA7 (2010 or later).
     #If Win64 Then
     'Code is running in 64-bit version of Microsoft Office.
      Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
      Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
      Public Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
      Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
      Private Declare PtrSafe Function IsIconic Lib "user32.dll" (ByVal hWnd As Long) As Long
     #Else
     'Code is running in 32-bit version of Microsoft Office.
      Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
      Private Declare Function CloseClipboard Lib "user32" () As Long
      Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
      Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
      Private Declare Function IsIconic Lib "user32.dll" (ByVal hWnd As Long) As Long
     #End If
#Else
'Code is running VBA6 (2007 or earlier).
#End If

Public IEObj As Object

Public Sub Activate_A_Window(WindowName As String)
    Dim IE As Object
    Dim Windows As Object: Set Windows = CreateObject("Shell.Application").Windows
    Dim Window As Object
    Dim my_title As String

    For Each Window In Windows
        my_title = Window.LocationName
        Debug.Print "Window Title = " & my_title
        If InStr(1, my_title, WindowName) Then
            Set IE = Window
            Exit For
        End If
    Next Window

    If Not IE Is Nothing Then
        If CBool(IsIconic(IE.hWnd)) Then
            ShowWindow IE.hWnd, SW_RESTORE
        End If
        SetForegroundWindow IE.hWnd
    Else
        Debug.Print (WindowName & " could not be located")
    End If
End Sub

Public Sub OpenIEURL(URL As String, Optional SecondURL As String)
    Application.Wait (Now() + TimeValue("00:00:01"))
    Set IEObj = CreateObject("InternetExplorer.Application")
    
    IEObj.navigate URL
    Do Until IEObj.readyState = 4
        DoEvents
    Loop
    IEObj.TheaterMode = True
    IEObj.Visible = True
 
    If SecondURL <> "" Then
        IEObj.navigate SecondURL
    End If
 
    HWNDSrc = IEObj.hWnd
    SetForegroundWindow HWNDSrc
    IEObj.Visible = False
    IEObj.Visible = True
    Call Activate_A_Window(URL)
End Sub

Public Sub CloseIEObj()
    IEObj.TheaterMode = False
    Application.Wait (Now() + TimeValue("00:00:04"))
    IEObj.Quit
    Set IEObj = Nothing
    Application.Wait (Now() + TimeValue("00:00:01"))
End Sub

主流程模块代码 #

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Public Const BM_CLICK = &HF5
Public Const WM_SETTEXT = &HC
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE

Private Sub File_Download_Click_Save()
    Dim hWnd As Long
    Dim timeout As Date
    
    Debug.Print "File_Download_Click_Save"
    timeout = Now + TimeValue("00:00:30")
    Do
        hWnd = FindWindow("#32770", "File Download")
        DoEvents
        Sleep 200
    Loop Until hWnd Or Now > timeout
    
    Debug.Print "   File Download window "; Hex(hWnd)
    
    If hWnd Then
        hWnd = FindWindowEx(hWnd, 0, "Button", "&Save")
        Debug.Print "   Save button "; Hex(hWnd)
    End If
    
    If hWnd Then
        SetForegroundWindow (hWnd)
        Sleep 600
        SendMessage hWnd, BM_CLICK, 0, 0
    End If
End Sub

Public Sub WVinput()
    Dim URL As String
    URL = "http://url.com"
    Call OpenIEURL(URL)
 
    IEObj.document.getElementById("buttonExcel").Click
    Application.Wait (Now() + TimeValue("00:00:10"))
    Call File_Download_Click_Save

    Dim o As IUIAutomation
    Dim h As LongPtr
    Set o = New CUIAutomation
    h = 0
    Do Until h > 0
        h = FindWindow("#32770", "Internet Explorer")
    Loop

    Dim e As IUIAutomationElement
    Dim iCnd As IUIAutomationCondition
    Dim Button As IUIAutomationElement
    Set e = o.ElementFromHandle(ByVal h)
    Set Button = Nothing
    Do Until Not Button Is Nothing
        Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Save")
        Set Button = e.FindFirst(TreeScope_Subtree, iCnd)
    Loop

    Dim InvokePattern As IUIAutomationInvokePattern
    Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
    InvokePattern.Invoke

    Application.Wait (Now() + TimeValue("00:00:02"))
    Call CloseIEObj
End Sub

待实现目标 #

• 适配现有自定义函数逻辑
• 实现IE下载提示“保存”按钮的自动点击
• 全程无SendKeys操作依赖

内容的提问来源于stack exchange，提问作者FreeSoftwareServers