VBA Internet 自动化代码在 ie.Visible = False 时不起作用

Question

早上好，我正在努力寻找有关互联网上似乎没有太多信息的问题的信息 - 即 Internet Explorer 中的“框架通知栏”(询问您是否要的黄色小窗口“保存”或“打开”下载的文件)。

切入正题，我遇到的问题是我的代码在 Internet Explorer 可见性设置为 true 时有效，但在可见性设置为 false 时不起作用。我已经在这两种情况下逐步查看代码以查看有什么变化，并注意到框架通知栏的句柄更改了值，但除此之外都是相同的。相关代码为:

Private 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

Sub StartIE()
    Dim appIE As Object
    Dim URLString As String
    Dim HTMLdoc, btn As Object
    Set appIE = CreateObject("internetexplorer.application") ' create an instance of internet explorer


    With appIE
        .Navigate "https://analytics.twitter.com/user" 'this url wont work for you. you will need to have your own twitter account on twitter analytics, and copy the link to the "tweets" page
        .Visible = True ' and show the IE
    End With
    Do While appIE.Busy Or (appIE.READYSTATE <> 4) ' wait until IE has finished loading

        DoEvents
    Loop

    URLString = appIE.LocationURL

    Set HTMLdoc = appIE.document
    Set btn = HTMLdoc.getElementsByClassName("btn btn-default ladda-button")(0) 'finds the export data button
    btn.Click
    Do While appIE.Busy Or (appIE.READYSTATE <> 4) ' wait until IE has finished loading
            DoEvents
    Loop

    Application.Wait (Now + TimeValue("0:00:07"))



    Dim hwnd As LongPtr, h As LongPtr


    Dim o As IUIAutomation ' The following steps are used to download a csv file from a webpage
    Dim e As IUIAutomationElement
    Set o = New CUIAutomation
    h = appIE.hwnd
    h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString) ' we must find the first frame notification handle
    If h = 0 Then Exit Sub
    Set e = o.ElementFromHandle(ByVal h) 
    Dim iCnd As IUIAutomationCondition
    Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Save") 
    Dim Button As IUIAutomationElement
    Set Button = e.FindFirst(TreeScope_Subtree, iCnd)
    Dim InvokePattern As IUIAutomationInvokePattern
    Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
    InvokePattern.Invoke


    h = appIE.hwnd
    h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString)
    If h = 0 Then Exit Sub

    Set e = o.ElementFromHandle(ByVal h)
    Dim iCnd2 As IUIAutomationCondition
    Set iCnd2 = o.CreatePropertyCondition(UIA_NamePropertyId, "Open") ' similar to the above snippet, except for the second stage of the frame notification window

    Dim Button2 As IUIAutomationElement
    Set Button2 = e.FindFirst(TreeScope_Subtree, iCnd2)
    Dim InvokePattern2 As IUIAutomationInvokePattern
    Set InvokePattern2 = Button2.GetCurrentPattern(UIA_InvokePatternId)
    InvokePattern2.Invoke

End Sub

在这段代码中，我认为出现问题的片段是:

    Dim o As IUIAutomation ' The following steps are used to download a csv file from a webpage
    Dim e As IUIAutomationElement
    Set o = New CUIAutomation
    h = appIE.hwnd
    h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString) ' we must find the first frame notification handle
    If h = 0 Then Exit Sub
    Set e = o.ElementFromHandle(ByVal h) 
    Dim iCnd As IUIAutomationCondition
    Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Save") 
    Dim Button As IUIAutomationElement
    Set Button = e.FindFirst(TreeScope_Subtree, iCnd)
    Dim InvokePattern As IUIAutomationInvokePattern
    Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
    InvokePattern.Invoke

谁能告诉我为什么会发生这种情况，我该如何解决？我知道我已经问了很多，但我真的很喜欢任何修复的解释，因为我正在努力提高我的理解，并发现它对处于类似情况的其他人有益:)

提前谢谢你。

Answer 1

看看下面的例子:

Option Explicit

Sub SaveTweetsToCsv()

    Dim sAuthToken As String
    Dim sUserName As String
    Dim sStartTime As String
    Dim sEndTime As String
    Dim aHeaders
    Dim sUrl As String
    Dim sParams As String
    Dim sResp As String

    ' Set init data
    sUserName = "myusername" ' Your username
    sStartTime = "1517184000000" ' UNIX time with milliseconds
    sEndTime = "1519603199999"
    ' Check saved auth token
    sAuthToken = GetEnvVar("user", "tw_auth_token")
    ' Retrieve auth token if missing
    If sAuthToken = "" Then sAuthToken = GetAuthToken()
    ' Prepare request parameters
    sUrl = "https://analytics.twitter.com/user/" & sUserName & "/tweets/"
    sParams = "start_time=" & sStartTime & "&end_time=" & sEndTime & "&lang=en"
    ' Set request auth token header
    aHeaders = Array(Array("cookie", "auth_token=" & sAuthToken))
    ' Make request and check availability
    Do
        ' Retrieve status
        WinHTTPRequest "POST", sUrl & "export.json?" & sParams, _
            "", _
            aHeaders, _
            "", _
            "", _
            sResp, _
            ""
        ' Check if auth token is invalid
        If InStr(sResp, "403 Forbidden") > 0 Then sAuthToken = GetAuthToken()
        ' Check report availability
        If InStr(sResp, """status"":""Available""") > 0 Then Exit Do
        DoEvents
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    ' Retrieve CSV content
    WinHTTPRequest "GET", sUrl & "bundle?" & sParams, _
        "", _
        aHeaders, _
        "", _
        "", _
        sResp, _
        ""
    ' Save CSV
    WriteTextFile sResp, CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\result.csv", -1
    MsgBox "Completed"

End Sub

Function GetAuthToken() As String

    Dim sLogin As String
    Dim sPassword As String
    Dim sHdrs As String
    Dim sResp As String
    Dim aSetHeaders
    Dim aTmp
    Dim sToken As String
    Dim aPayload
    Dim sPayload As String
    Dim aOptions
    Dim i As Long

    If MsgBox("Login", vbOKCancel) = vbCancel Then End
    sLogin = "mylogin" ' Your login
    sPassword = "mypassword" ' Your password
    ' Retrieve login form
    WinHTTPRequest "GET", "https://twitter.com/", _
        "", _
        "", _
        "", _
        sHdrs, _
        sResp, _
        ""
    ' Extract cookies from headers
    ParseResponse "^Set-(Cookie): (\S*?=\S*?);[\s\S]*?$", sHdrs, aSetHeaders
    ' Extract authenticity_token from login form
    aTmp = Split(sResp, """ name=""authenticity_token""", 2)
    If UBound(aTmp) = 0 Then MsgBox "Failed to get authenticity token": End
    sToken = Mid(aTmp(0), InStrRev(aTmp(0), """") + 1)
    ' Prepare payload for login request
    aPayload = Array( _
        Array("session[username_or_email]", sLogin), _
        Array("session[password]", sPassword), _
        Array("remember_me", "1"), _
        Array("return_to_ssl", "true"), _
        Array("scribe_log", ""), _
        Array("redirect_after_login", "/"), _
        Array("authenticity_token", sToken), _
        Array("ui_metrics", "") _
    )
    For i = 0 To UBound(aPayload)
        aPayload(i) = EncodeUriComponent((aPayload(i)(0))) & "=" & EncodeUriComponent((aPayload(i)(1)))
    Next
    sPayload = Join(aPayload, "&")
    ' Add web form headers
    PushItem aSetHeaders, Array("Content-Type", "application/x-www-form-urlencoded")
    PushItem aSetHeaders, Array("Content-Length", Len(sPayload))
    ' WinHTTP option disabling redirections
    aOptions = Array(Array(6, False)) ' redirectoins disabled
    ' Login request
    WinHTTPRequest "POST", "https://twitter.com/sessions", _
        aOptions, _
        aSetHeaders, _
        sPayload, _
        sHdrs, _
        sResp, _
        ""
    ' Extract auth_token from received headers
    aTmp = Split(sHdrs, "auth_token=", 2)
    If UBound(aTmp) = 0 Then MsgBox "Failed to get auth token": End
    GetAuthToken = Split(aTmp(1), ";", 2)(0)
    ' Save auth token to user env var for further usage
    SetEnvVar "user", "tw_auth_token", GetAuthToken
    MsgBox "Auth token retrieved successfully"

End Function

Sub SetEnvVar(sEnv As String, sName As String, sValue As String)

    CreateObject("WSCript.Shell").Environment(sEnv).Item(sName) = sValue

End Sub

Function GetEnvVar(sEnv As String, sName As String) As String

    GetEnvVar = CreateObject("WSCript.Shell").Environment(sEnv).Item(sName)

End Function

Sub WinHTTPRequest(sMethod, sUrl, aSetOptions, aSetHeaders, vFormData, sRespHeaders, sRespText, aRespBody)

    Dim aItem

    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open sMethod, sUrl, False
        If IsArray(aSetOptions) Then
            For Each aItem In aSetOptions
                .Option(aItem(0)) = aItem(1)
            Next
        End If
        If IsArray(aSetHeaders) Then
            For Each aItem In aSetHeaders
                .SetRequestHeader aItem(0), aItem(1)
            Next
        End If
        .send (vFormData)
        sRespHeaders = .GetAllResponseHeaders
        sRespText = .ResponseText
        aRespBody = .ResponseBody
    End With
End Sub

Sub ParseResponse(sPattern, sResponse, aData, Optional bAppend As Boolean = True, Optional bGlobal As Boolean = True, Optional bMultiLine As Boolean = True, Optional bIgnoreCase As Boolean = True)

    Dim oMatch
    Dim aTmp()
    Dim sSubMatch

    If Not (IsArray(aData) And bAppend) Then aData = Array()
    With CreateObject("VBScript.RegExp")
        .Global = bGlobal
        .MultiLine = bMultiLine
        .IgnoreCase = bIgnoreCase
        .Pattern = sPattern
        For Each oMatch In .Execute(sResponse)
            If oMatch.SubMatches.Count = 1 Then
                PushItem aData, oMatch.SubMatches(0)
            Else
                aTmp = Array()
                For Each sSubMatch In oMatch.SubMatches
                    PushItem aTmp, sSubMatch
                Next
                PushItem aData, aTmp
            End If
        Next
    End With

End Sub

Sub PushItem(aData, vItem, Optional bAppend As Boolean = True)

    If Not (IsArray(aData) And bAppend) Then aData = Array()
    ReDim Preserve aData(UBound(aData) + 1)
    aData(UBound(aData)) = vItem

End Sub

Function EncodeUriComponent(sText As String) As String

    Static objHtmlfile As Object

    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
    End If
    EncodeUriComponent = objHtmlfile.parentWindow.encode(sText)

End Function

Sub WriteTextFile(sContent As String, sPath As String, lFormat As Long)

    With CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath, 2, True, lFormat)
        .Write sContent
        .Close
    End With

End Sub

注意。网站自动检测到过多的身份验证 token 请求，这可能会导致帐户被阻止，在这种情况下，您将需要输入验证码并确认您的电话号码以通过短信接收验证码。这就是为什么一旦检索到身份验证 token 就将其保存到环境变量中以供进一步使用。