如何使用 VBA 在 IE11 中自动保存另存为对话框?

问题描述

我正在尝试下载一些有关碳排放的数据.我可以通过 URL 预加载具有相关设置的页面.它加载正常，我可以通过其 ID 单击确定按钮，然后在底部看到 IE11 - 打开/保存/取消对话框.我已经使用 FindWindows (#32770) 尝试了所有建议，还尝试了非常不可靠的 Send Keys.有人可以建议操作此对话框的代码，或者检查网页上的 HTML 以查看是否可以直接下载?

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 then I get the IE11 - Open/Save/Cancel Dialogue at the bottom. I have tried all suggestions using FindWindows (#32770) and also Send Keys which is very unreliable. Can someone suggest the code to manipulate this dialogue box or else perhaps examine the HTML on the web page to see if a direct download would be possible?

Dim htm As Object
Dim IE As Object
Dim Doc As Object

Set IE = CreateObject("internetexplorer.application")
IE.Visible = True
IE.Navigate "http://ec.europa.eu/environment/ets/exportEntry.do?form=accountAll&permitIdentifier=&accountID=&installationIdentifier=&complianceStatus=&account.registryCodes=CY&primaryAuthRep=&searchType=account&identifierInReg=&mainActivityType=&buttonAction=&account.registryCode=&languageCode=en&installationName=&accountHolder=&accountStatus=&accountType=&action=&registryCode="
Do While IE.readystate <> 4: DoEvents: Loop
Set Doc = CreateObject("htmlfile")
Set Doc = IE.document
Doc.getelementbyID("btnOK").Click [embed=file 884739]

'I need code here which clicks the save as button as save the file as C:	emp.xml

Set IE = Nothing

推荐答案

考虑这个例子:

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") & "	emp.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

这篇关于如何使用 VBA 在 IE11 中自动保存另存为对话框?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！