VBA Internet automation code not working when ie.Visible = False

Question

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

Answer 1

Take a look at the below example:

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

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.