当ie.Visible = False时，VBA Internet自动化代码不起作用 [英] VBA Internet automation code not working when ie.Visible = False

问题描述

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

Good morning, I am struggling to find information on a problem which seems to not have much information available on the internet - that is the "frame notification bar" in internet explorer ( the little yellow window that asks you if you want to "save" or "open" a file downloaded).

我将继续追逐，我遇到的问题是，当Internet Explorer的可见性设置为true时，我的代码可以工作，而当可见性设置为false时，我的代码则无法工作.在这两种情况下，我都逐步执行了代码，以查看发生了什么变化，并注意到帧通知栏的句柄更改了值，但除此之外，其余部分都是相同的.相关代码为:

I will cut to the chase, the issue I am having is that my code works when an internet explorer visibility is set to true, but doesn't work when visibility is set to false. I have stepped through the code in both situations to see what changes, and noticed the handle for the frame notification bar changes value but other than that all are the same. The relevant code is:

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

在此代码之外，我认为发生此问题的代码段位于:

Out of this code, the snippet where I believe the issue is occurring is in:

    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

谁能为我提供一个可能的原因以及如何解决的想法?我知道我已经在问很多了，但是我真的很想在任何解决方法旁边加上一个解释，因为我正努力增进我的理解，发现它会对类似情况下的其他人有所帮助:)

Can anyone provide me with an idea of why this might be happening, and how I might fix it? I know I'm asking alot already but I would really love an explanation alongside any fix as I am trying to improve my understanding, and find it will be beneficial to others in a similar situation :)

先谢谢您.

推荐答案

看看下面的例子:

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

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

Note. Excessive auth token requests are detected by the web site as automated, that may lead to the account to be blocked, in that case you will need to enter the captcha and confirm your phone number to receive a code by SMS. That is why auth token is saved to environment variable once it is retrieved, for further usage.

这篇关于当ie.Visible = False时，VBA Internet自动化代码不起作用的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！