Hello I'm having issues grabbing an excel sheet from vba
my code is as follow:
Sub transfercsv()
sCSVLink = "http://ets.aeso.ca/Market/Reports/Manual/Operations/prodweb_reports/wind_power_forecast/WPF_ShortTerm.csv"
sfile = "options_code_list.csv"
ssheet = "CSV Transfer"
Dim myURL As String
myURL = "http://ets.aeso.ca/Market/Reports/Manual/Operations/prodweb_reports/wind_power_forecast/WPF_ShortTerm.csv"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False
WinHttpReq.Send
myURL = WinHttpReq.ResponseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.ResponseBody
oStream.SaveToFile ("C:\file.csv")
oStream.Close
End If
Right now when the code runs, it chops off the data that I am trying to save down. Any solution for this?
Thanks
Dim wb
Set wb = Workbooks.Open("http://ets.aeso.ca/Market/Reports/Manual/Operations/" & _
"prodweb_reports/wind_power_forecast/WPF_ShortTerm.csv")
Debug.Print wb.Sheets(1).UsedRange.Rows.Count '>> 18
I couldn't find an issue with the data being cutoff, it seems like anyone can run this report.
I cleaned up the approach to as there seemed to be some variables not needed and some other issues. Revised code below.
Code
Option Explicit
Sub SOExample()
Const OutputFilePath As String = "C:\Users\Ryan\Desktop\file.csv"
Const myURL As String = "http://ets.aeso.ca/Market/Reports/Manual/Operations/prodweb_reports/wind_power_forecast/WPF_ShortTerm.csv"
Const adTypeBinary = 1
Dim response() As Byte
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", myURL, False
.Send
response = .ResponseBody
End With
If UBound(response) > 0 Then
'Delete the file before saving?
With CreateObject("Scripting.FileSystemObject")
If .FileExists(OutputFilePath) Then Kill OutputFilePath
End With
With CreateObject("ADODB.Stream")
.Open
.Type = adTypeBinary
.Write response
.SaveToFile (OutputFilePath)
.Close
End With
End If
End Sub
Here are a couple ideas for you to try.
Sub DownloadFile()
Dim myURL As String
myURL = "http://www.asx.com.au/data/options_code_list.csv"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.Send
myURL = WinHttpReq.ResponseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.ResponseBody
oStream.SaveToFile "C:\Users\Excel\Desktop\Coding\Microsoft Excel\Bank of China\downloadCSV.csv", 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
Sub transfercsv()
sCSVLink = "http://www.asx.com.au/data/options_code_list.csv"
sfile = "options_code_list.csv"
ssheet = "CSV Transfer"
Set wnd = ActiveWindow
Application.ScreenUpdating = False
Sheets(ssheet).Cells.ClearContents
Workbooks.Open Filename:=sCSVLink
Windows(sfile).Activate
ActiveSheet.Cells.Copy
wnd.Activate
Sheets("CSV Transfer").Paste
Application.DisplayAlerts = False
Windows(sfile).Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Related
I am trying to directly open an axf file in excel and then using my other functions I format the data. The problem I am having is sometimes the file opens without any delay and sometimes it never open and hangs the excel.
Sub Workbook_Open()
Dim OriginalSecuritySetting As MsoAutomationSecurity
sCSVLink = "http://www.bom.gov.au/fwo/IDQ60801/IDQ60801.99367.axf"
sfile = "IDQ60801.99367.axf"
ssheet = "Hay_Point_Data"
Set wnd = ActiveWindow
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets(ssheet).Cells.ClearContents
OriginalSecuritySetting = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Workbooks.Open Filename:=sCSVLink
End Sub
Please advise how can I make it to run every time. Thanks
You need something like this: How do I download a file using VBA (without Internet Explorer)
Answered by Ole Henrik Skogstrøm
To open the same file, you need to import the data type, in this way, it is possible to identify the workbook and finish its adjustments.
Good Luck
Sub DownloadFile()
Dim myURL As String
Dim SrtPath As String
Dim SrtFile As String
myURL = "http://www.bom.gov.au/fwo/IDQ60801/IDQ60801.99367.axf"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send
SrtPath = ActiveWorkbook.Path & "\" & "IDQ60801.yourname.axf"
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile SrtPath, 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
Workbooks.Open Filename:=SrtPath
End Sub
when I try to download a large file (2GB) using this function this error appears "not enough memory resources are available to complete this operation". so, what can I do?
Function DownloadFile(ByVal URL As String, ByVal Path As String, ByVal UserName As String, ByVal Password As String) As Boolean
DownloadFile = False
Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER = 0
Dim WinHttpReq As Object
Dim oStream As Object
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
WinHttpReq.Open "GET", URL, False
WinHttpReq.SetCredentials UserName, Password, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
WinHttpReq.send
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile Path, 2
oStream.Close
DownloadFile = True
Set WinHttpReq = Nothing
Set oStream = Nothing
End Function
this is my code and it is working fine and you can set the chunk size. if you have any improvement in the logic please tell me
Sub Download()
Dim UserName As String
Dim Password As String
Dim Path As String
Dim url As String
Dim chunkSize As Long
UserName = ""
Password = ""
Path = ""
url = ""
chunkSize = 500000000 '500 mega
Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER = 0
Dim WinHttpReq As Object
Dim oStream As Object
Dim iStream As Object
Dim totalSize As Double
Dim currentStartByte As Double
Dim currentEndByte As Double
'get the total file size
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
WinHttpReq.Open "HEAD", url, False
WinHttpReq.SetCredentials UserName, Password, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
WinHttpReq.setRequestHeader "User-Agent", 0
WinHttpReq.send
totalSize = WinHttpReq.getResponseHeader("Content-Length")
Set WinHttpReq = Nothing
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1 'adTypeBinary
'set the initial start and end byte
currentStartByte = 0
if totalSize < chunkSize then
currentEndByte = totalSize
else
currentEndByte = chunkSize
end if
Dim firstloop As Boolean
firstloop = True
Do While (currentEndByte > currentStartByte)
Set iStream = CreateObject("ADODB.Stream")
iStream.Open
iStream.Type = 1 'adTypeBinary
'read the data from the saved file to out stream
If firstloop = False Then
iStream.LoadFromFile Path
oStream.Write iStream.Read
End If
'read the chunked data from the responseBody to out stream
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
WinHttpReq.Open "GET", url, False
WinHttpReq.SetCredentials UserName, Password, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
WinHttpReq.setRequestHeader "User-Agent", 0
WinHttpReq.setRequestHeader "Range", "bytes=" + Str(currentStartByte) + "-" + Str(currentEndByte)
WinHttpReq.send
oStream.Write WinHttpReq.responseBody
'save out stream to the file
oStream.SaveToFile Path, IIf(1, 2, 1)
'set the start and end byte for the next loop
currentStartByte = currentStartByte + chunkSize + 1
currentEndByte = currentEndByte + chunkSize + 1
'if the remaining byte less than chunk size
If currentEndByte > totalSize Then
currentEndByte = totalSize
End If
firstloop = False
Set WinHttpReq = Nothing
iStream.Close
Set iStream = Nothing
Loop
oStream.Close
Set oStream = Nothing
End Sub
I've a VBA script which download files from a website but when the PDF file is being downloaded and when I tried to save it to my local drive of the system I'm getting an error called run time error '3004': Write to file failed. My code is as following:
Sub login()
Dim objIE As InternetExplorer
Dim uid As String
Dim pwd As String
Dim rng As Range
Dim sh As Worksheet
Dim objCollection As Object
Dim buttonCollection As Object
Dim ieElement As Object
Dim ieButton As Object
Dim WinHttpReq As Object
Dim oStream As Object
Dim MyURL As String
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
Set sh = Sheets("Indeed Resume Download")
Set rng = sh.Range("A2")
uid = rng.Value
pwd = rng.Offset(0, 1).Value
Dim j As Long
Set objIE = New InternetExplorer 'Initialize internet object
objIE.Navigate "https://secure.indeed.com/account/login?service=my&hl=en_IN&co=IN&continue=https%3A%2F%2Fwww.indeed.co.in%2F"
objIE.Visible = True
objIE.Document.all.signin_email.Value = uid
objIE.Document.all.signin_password.Value = pwd
Set ieElement = objIE.Document.getElementsByClassName("sg-btn sg-btn-primary btn-signin")(0)
ieElement.Click
For j = 2 To sh.Cells(Rows.Count, 27).End(xlUp).Row
Set objIE = New InternetExplorer
objIE.Visible = True
MyURL = sh.Range("XDA" & j).Value
objIE.Navigate MyURL
Do While objIE.Busy = True
DoEvents
Loop
Set ieButton = objIE.Document.getElementsByClassName("button download_button"(0)
ieButton.Click
WinHttpReq.Open "GET", MyURL, False
WinHttpReq.Send
MyURL = WinHttpReq.responseBody
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile ("D:\Downloaded Indeed Resume - Store")
oStream.Close
Next j
Set objIE = Nothing
End Sub
Sub Save_image()
Dim oHTTP As Object
Dim sDestFolder As String
Dim sSrcUrl As String
Dim sImageFile As String
sDestFolder = "C:\Users\adale\Desktop\Compendium Images\"
sSrcUrl = ActiveCell.Value
If Left(sSrcUrl, 2) = "//" Then
sSrcUrl = "http:" & sSrcUrl
End If
sImageFile = Right(ActiveCell.Value, Len(ActiveCell.Value) - InStrRev(ActiveCell.Value, "/"))
Debug.Print sImageFile
ActiveCell.Offset(0, 2).Value = sImageFile
Set oHTTP = CreateObject("msxml2.XMLHTTP")
oHTTP.Open "GET", sSrcUrl, False
oHTTP.send
Set oStream = CreateObject("ADODB.Stream")
Const adTypeBinary = 1
Const adSaveCreateOverWrite = 2
oStream.Type = adTypeBinary
oStream.Open
oStream.write oHTTP.responseBody
oStream.savetofile sDestFolder & sImageFile, adSaveCreateOverWrite
Set oStream = Nothing
Set oHTTP = Nothing
End Sub
Sourced the above code from: http://tipsformarketers.com/use-excel-to-download-hundreds-of-images-instantly/
I have an Excel sheet with 3 columns all containing URLs to images, see example image attached:
What VBA routine could handle running through each column, downloading the image to the local computer (PC) whilst also creating/maintaining the directory structure, e.g. creating local nested folders: /wp-content/uploads/XXXX/XX/file_name.jpg.
I am trying to download a file from IBM Cognos via Excel VBA. The script will execute, but I only get a 9KB Excel file that will not open. How do I make this work?
Here is my code:
Sub ado_stream()
'add a reference to Microsoft XML v6 and MS ActiveX Data Objects
'via Tools/References
'This assumes the workbook is saved already, and that you want the file in the same folder
Dim fileStream As ADODB.Stream
Dim xmlHTTP As MSXML2.xmlHTTP
Dim strURL As String
strURL = "http://foo.bar"
Set xmlHTTP = New MSXML2.xmlHTTP
xmlHTTP.Open "GET", strURL, False, "username", "password"
xmlHTTP.Send
If xmlHTTP.status <> 200 Then
MsgBox "File not found"
GoTo exitsub
End If
Set fileStream = New ADODB.Stream
With fileStream
.Open
.Type = adTypeBinary
.Write xmlHTTP.responseBody
.Position = 0
.SaveToFile "C:\Users\myname\Downloads\Test.xlsx"
.Close
End With
exitsub:
Set fileStream = Nothing
Set xmlHTTP = Nothing
End Sub
try sending the password via auth header. see if that works.
Set xmlHTTP = New MSXML2.xmlHTTP
xmlHTTP.Open "GET", strURL, False
xmlHTTP.setRequestHeader "Authorization", "Basic " & EncodeBase64
xmlHTTP.Send
'EncodeBase Function. Put your actual user name and password here.
Private Function EncodeBase64() As String
Dim arrData() As Byte
arrData = StrConv("<<username>>" & ":" & "<<password>>", vbFromUnicode)
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
EncodeBase64 = objNode.text
Set objNode = Nothing
Set objXML = Nothing
End Function