How can I automate Save as dialog box in IE11 using VBA?

Question

I am trying to download some data on carbon emissions. I can preload the page with the relevant settings via the URL. It loads fine and I can click the OK button by its ID t

Answer 1

Consider the example:

Option Explicit

Sub Test()
    Dim strExportURL As String
    Dim strFormData As Variant
    Dim strContent As String
    Dim arrRespBody() As Byte

    ' build exportURL parameter
    strExportURL = Join(Array( _
        "permitIdentifier=", _
        "accountID=", _
        "form=accountAll", _
        "installationIdentifier=", _
        "complianceStatus=", _
        "account.registryCodes=CY", _
        "primaryAuthRep=", _
        "searchType=account", _
        "identifierInReg=", _
        "mainActivityType=", _
        "buttonAction=", _
        "account.registryCode=", _
        "languageCode=en", _
        "installationName=", _
        "accountHolder=", _
        "accountStatus=", _
        "accountType=", _
        "action=", _
        "registryCode=" _
    ), "&")

    ' build the whole form data
    strFormData = Join(Array( _
        "languageCode=en", _
        "exportURL=" & EncodeUriComponent(strExportURL), _
        "form=accountAll", _
        "exportType=1", _
        "OK=Ok" _
    ), "&")

    ' POST XHR to retrieve the content
    With CreateObject("Microsoft.XMLHTTP")
        .Open "POST", "http://ec.europa.eu/environment/ets/export.do", False
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .Send strFormData
        arrRespBody = .ResponseBody
        ' strRespText = .ResponseText
        ' strRespHeaders = .GetAllResponseHeaders
        ' strStatus = .Status
    End With

    ' some processing examples

    ' convert to string
    strContent = BinaryToText(arrRespBody, "utf-8")
    ' replace LF symbols with CRLF for line breaks to be displayed right
    strContent = Replace(strContent, vbLf, vbCrLf)
    ' show in notepad
    ShowInNotepad strContent

    ' save to temp.xml file on the desktop folder
    SaveBinaryToFile arrRespBody, CreateObject("WScript.Shell").SpecialFolders.Item("Desktop") & "\temp.xml"

End Sub

Function EncodeUriComponent(sText)
    With CreateObject("ScriptControl")
        .Language = "JScript"
        EncodeUriComponent = .Run("encodeURIComponent", sText)
    End With
End Function

Sub ShowInNotepad(strToFile)
    Dim strTempPath
    With CreateObject("Scripting.FileSystemObject")
        strTempPath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%TEMP%") & "\" & .GetTempName
        With .CreateTextFile(strTempPath, True, True)
            .WriteLine (strToFile)
            .Close
        End With
        CreateObject("WScript.Shell").Run "notepad.exe " & strTempPath, 1, True
        .DeleteFile (strTempPath)
    End With
End Sub

Function BinaryToText(arrBytes() As Byte, strCharSet As String)
    With CreateObject("ADODB.Stream")
        .Type = 1 ' adTypeBinary
        .Open
        .Write arrBytes
        .Position = 0
        .Type = 2 ' adTypeText
        .Charset = strCharSet
        BinaryToText = .ReadText
        .Close
    End With
End Function

Sub SaveBinaryToFile(arrBytes() As Byte, strPath As String)
    With CreateObject("ADODB.Stream")
        .Type = 1 ' adTypeBinary
        .Open
        .Write arrBytes
        .SaveToFile strPath, 2 ' adSaveCreateOverWrite
        .Close
    End With
End Sub