如何使用 VBA 在 IE11 中自动保存另存为对话框?
How can I automate Save as dialog box in IE11 using VBA?
我正在尝试下载一些关于碳排放量的数据。我可以通过 URL 预加载具有相关设置的页面。
它加载正常,我可以通过它的 ID 单击确定按钮,然后我在底部得到 IE11 - Open/Save/Cancel 对话框。我已经尝试了所有使用 FindWindows (#32770) 的建议,还尝试了非常不可靠的 Send Keys。有人可以建议操作此对话框的代码,或者检查网页上的 HTML 以查看是否可以直接下载吗?
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=®istryCode="
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:\temp.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") & "\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
我正在尝试下载一些关于碳排放量的数据。我可以通过 URL 预加载具有相关设置的页面。 它加载正常,我可以通过它的 ID 单击确定按钮,然后我在底部得到 IE11 - Open/Save/Cancel 对话框。我已经尝试了所有使用 FindWindows (#32770) 的建议,还尝试了非常不可靠的 Send Keys。有人可以建议操作此对话框的代码,或者检查网页上的 HTML 以查看是否可以直接下载吗?
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=®istryCode="
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:\temp.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") & "\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