Using VBA to download a webbased Excel File and saving it locally.

[TopherGeorge]

I really need some help. I am about to make my database live but I have one big problem I need to overcome.

At the moment I can manually download the ProjectData.xls file from the company website using a url similar to www.companyname.com/discovery/ProjectData.xls. I have then written the code that pulls this local file into the database and updates all the tables. However I am going into hospital for an operation so will be out of action so this needs to be added in. Therefore I need help :

• 1. I need to download the ProjectData.xls file from www.companyname.com/discovery/ProjectData.xls, this link promts an Open, Save, Cancel Dialog box in explorer.
• 2. Automatically save this file locally to C:\Documents and Settings\User\My Documents\ProjectDataFiles
• Then follow into my own code that updates the files, which is already done.

Topher Tastic

 

[TopherGeorge]

I have also tried the following but with no luck, i get "RUNTIME ERROR 3004, Write to file failed"


Option Compare Database
Sub downloadpde()

Dim myURL As String
myURL = http://companyname.com/ProjectData.xls
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:\Documents and Settings\Users\My Documents\ProjectDataFiles)
oStream.Close
End If
End Sub

 

[smig]

sub DwonloadFile()
 
[INDENT]dim strHTTP as string
dim strFileToSave as string
 
strHTTP = HTTP_File_Address
strFileToSave = Local_File_Name
 
if fnDownloadHTTP(strHTTP, strFileToSave) = False then
  MsgBox "Download failed"
end if
[/INDENT] 
end sub
 
 
function fnDownloadHTTP(strHTTP as string, strFileToSave as string)
 
[INDENT]dim xmlHTTP as Object
dim strRespText as string
 
fnDownloadHTTP = True
 
set xmlHTTP = CreateObject("Microsoft.XMLHTTP")
 
with xmlHTTP
  .Open "GET" strHTTP, False
  .setRequestHeader "cache-control", "no-cache, must revalidate"
  .send
  if fnSaveDownloadFile(strFileToSave, .respondseBody) = False then
    fnDownloadHTTP = False
  end if
end with
set xmlHTTP = Nothing
[/INDENT] 
end function
 
 
 
function fnSaveDownloadFile(strFileToSave as string, bytArray) as Boolean
 
[INDENT]on error goto errHere
 
dim objStream as Object
 
fnSaveDownloadFile = True
 
Set objStream = CreateObject("ADODB.Stream")
 
with objStream
  .Type = 1   ' adTypeBinary
  .Open
  .Write bytArray
  .SaveToFile strFileToSave, 2   ' adSaveCreateOverWrite
end with
set objStream = Nothing
 
exitHere
  exitFunction
 
errHere
  fnSaveDownloadFile = False
  resume exitHere
[/INDENT] 
end Function

you can easily put it all in one segment of code.
I prefer small reusable functions

 

[TopherGeorge]

This is great, I had something implmented but Im having problems with the code I have so I will try it with what you have added in.

Can you tell, will this ensure that it overwrites the file that it replaces everytime it downloads. The code i put together should use the overwriteKill function to delete the old file but its just not working.

 

[smig]

Can you tell, will this ensure that it overwrites the file that it replaces everytime it downloads. The code i put together should use the overwriteKill function to delete the old file but its just not working.

using the adSaveCreateOverWrite should

you can read more here:
http://support.microsoft.com/kb/276488
and even more here:
http://www.w3schools.com/ado/ado_ref_stream.asp
and the SaveToFile method: http://www.w3schools.com/ado/met_stream_savetofile.asp

 

[TopherGeorge]

I am having issues with the:
I am getting an error here .Open "GET" strHTTP, False

 

[TopherGeorge]

The code I am using looks as below, can you see if its right. I have assigned the first function to a button that runs upon clicking:

Option Compare Database
Option Explicit

Private Sub Command74_Click()
Dim strHTTP As String
Dim strFileToSave As String
 
strHTTP = "[URL]http://MyCompany.com/Discovery/livelink/53148462/ProjectData.xlsx?func=doc.Fetch&nodeid=500000[/URL]"
strFileToSave = "C:\Documents and Settings\UserName\My Documents\Project Data .xlsx"
 
If fnDownloadHTTP(strHTTP, strFileToSave) = False Then
  MsgBox "Download failed"
End If
End Sub
 
Function fnDownloadHTTP(strHTTP As String, strFileToSave As String)
Dim xmlHTTP As Object
Dim strRespText As String
 
fnDownloadHTTP = True
 
Set xmlHTTP = CreateObject("Microsoft.XMLHTTP")
 
With xmlHTTP
  .Open "GET" strHTTP, False
  .setRequestHeader "cache-control", "no-cache, must revalidate"
  .send
  If fnSaveDownloadFile(strFileToSave, .respondseBody) = False Then
    fnDownloadHTTP = False
  End If
End With
Set xmlHTTP = Nothing
End Function
 
 
 
Function fnSaveDownloadFile(strFileToSave As String, bytArray) As Boolean
 On Error GoTo errHere
 
Dim objStream As Object
 
fnSaveDownloadFile = True
 
Set objStream = CreateObject("ADODB.Stream")
 
With objStream
  .Type = 1   ' adTypeBinary
  .Open
  .Write bytArray
  .SaveToFile strFileToSave, 2   ' adSaveCreateOverWrite
End With
Set objStream = Nothing
 
exitHere
  exitFunction
 
errHere
  fnSaveDownloadFile = False
  Resume exitHere
End Function

 

[TopherGeorge]

I have actually corrected the last bit, just realised there is a comma that needed inserting after "Get".

The code is failing at the following place, but I just cant work out why?
If fnSaveDownloadFile(strFileToSave, .respondseBody) = False Then
fnDownloadHTTP = False

 

[smig]

here is the exact code I'm using (I changed some parts of my specific coding )

Public Sub DownloadFile()
On Error GoTo errHere
 
Dim strQRY As String
 
Dim strHTTP As String
Dim strFileToSave As String
 
strHTTP = "[URL="http://www.bankisrael.gov.il/deptdata/pikuah/snifim/snifim.xls"]File To Download HTTP Address[/URL]"
strFileToSave = "Full_Path_And_File_Name_To_Save"
 
If fnDownloadHTTP(strHTTP, strFileToSave) = False Then      ' -- downlaod the file
    MsgBox "File DL failed. Make sure folder exist"
    GoTo ExitHere
End If
 
MsgBox "Thumbs up :-)" 
 
ExitHere:
    Exit Sub
errHere:
    MsgBox "Error"
    Resume ExitHere
End Sub
 
Public Function fnDownloadHTTP(strTarget As String, strSaveAs As String, Optional strUN As String, Optional strPW As String) As Boolean
On Error GoTo errHere
 
Dim xmlHTTP As Object
Dim strRespText As String
fnDownloadHTTP = True
Set xmlHTTP = CreateObject("Microsoft.XMLHTTP")
With xmlHTTP
    .Open "GET", strTarget, False, strUN, strPW
    .setRequestHeader "cache-control", "no-cache,must revalidate"
    .Send
    If fnSaveDownloadFile(strSaveAs, .responseBody) = False Then
        GoTo errHere
    End If
End With
 
ExitHere:
    Set xmlHTTP = Nothing
    Exit Function
 
errHere:
    fnDownloadHTTP = False
    Resume ExitHere
End Function
 
Private Function fnSaveDownloadFile(strFilePath, bytArray) As Boolean
On Error GoTo errHere
 
 
Dim objStream  As Object 'New ADODB.Stream
fnSaveDownloadFile = True
Set objStream = CreateObject("ADODB.Stream")
With objStream
    .Type = 1 'adTypeBinary
    .Open
    .Write bytArray
    .SaveToFile strFilePath, 2 'adSaveCreateOverWrite
End With
 
ExitHere:
    Exit Function
errHere:
    fnSaveDownloadFile = False
    Resume ExitHere
End Function