Код VBA для автоматизации интернета не работает, когда ie.Visible = False

Question

Код VBA для автоматизации интернета не работает, когда ie.Visible = False

Доброе утро, я изо всех сил пытаюсь найти информацию о проблеме, которая, кажется, не имеет много информации, доступной в Интернете - это "панель уведомлений о кадрах" в 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

Кто-нибудь может дать мне представление о том, почему это может происходить, и как я могу это исправить? Я знаю, что уже много спрашиваю, но мне бы очень хотелось, чтобы объяснение было рядом с любым исправлением, поскольку я пытаюсь улучшить свое понимание, и считаю, что оно будет полезным для других в аналогичной ситуации:)

Заранее спасибо.

3

vba internet-explorer browser-automation notification-bar

Источник

user9261208 20 фев '18 в 09:18

1 ответ

Другие вопросы по тегам vba internet-explorer browser-automation notification-bar

user2165759 05 мар '18 в 01:49 2018-03-05 01:49 · Answer 1 · 2018-03-05 01:49

Посмотрите на приведенный ниже пример:

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. Вот почему токен аутентификации сохраняется в переменной среды после получения для дальнейшего использования.