Copying (downloading) a file knowing its URL (With VBA).

[Bastringue]

Hello,
I would like to copy (download) a File located on a URL. This URL is located on a OneDrive Cloud space (maybe it plays a part).
I have checked that I have a R/W authorization on this file, granted by the owner of the Drive.
Moreover, this file is an Excel Workbook that I can open and load in my Internet browser (works fine).

Now I would like to copy it by a VBA code. I have used code we can easily find in many places, given below.
Unfortunately, it does not work for me.

By any chance, would you know how to copy an Excel Workbook from a OneDrive location to a local directory ? ...Thanks in advance



Option Explicit

Declare PtrSafe Function URLDownloadToFile _
Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As LongPtr

Private Const ERROR_SUCCESS As Long = 0

Public Function DownloadFile(ByVal sURL As String, ByVal sLocalFile As String) As Boolean
Dim lngRetVal As LongPtr
DownloadFile = URLDownloadToFile(0&, sURL, sLocalFile, 0&, 0&) = ERROR_SUCCESS
End Function

Option Explicit

Declare PtrSafe Function URLDownloadToFile _
Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As LongPtr

Private Const ERROR_SUCCESS As Long = 0

Public Function DownloadFile(ByVal sURL As String, ByVal sLocalFile As String) As Boolean
Dim lngRetVal As LongPtr
DownloadFile = URLDownloadToFile(0&, sURL, sLocalFile, 0&, 0&) = ERROR_SUCCESS
End Function

Sub go()
DownloadFile "https://d.docs.live.net/181eeee77f46f4563/Documents/file.xlsm", "C:\file.xlsm"
End Sub

[Aussiebear]

maybe try a version of this?



Sub open_excel_from_one_drive()
sfilename = "https://d.docs.live.net/18leeee77f46f4563/Documents/file.xlsm" '<----- Change to suit your file name
Set xl = CreateObject("Excel.Sheet")
Set xlsheet = xl.Application.Workbooks.Open(Filename:=sfilename, ReadOnly:=True)
End Sub

[Aussiebear]

this is another version that I found.



Sub DownloadFile()
'Declare the Object and URL
Dim myURL As String
Dim WinHttpReq As Object
'Assign the URL and Object to Variables
myURL = "https://d.docs.live.net/18leeee77/f46/4563/Documents/file.xlsm"
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
'Provide Access Token and PWD to the URL for getting the service from API
WinHttpReq.Open "GET", myURL, False, "abcdef", "12345"
WinHttpReq.send
Debug.Print WinHttpReq.Status
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:\testdownload.xlsx", 2
oStream.Close
End If
End Sub

[Bastringue]

Thank you for these ideas... actually I think your first idea was the good one for me. I have slightly modified it to obtain this routine that works well...
I did not try the second one but I am afraid it downloads the html content of the URL we would have if we opened the file in a browser and not the file itself...(I am not sure).
thanks again...



Function DownloadFile(URL As String, LocalPath As String) As Boolean
Dim result As Long
Dim newWB As Workbook
Dim xl As Application

Set xl = CreateObject("Excel.Application")
xl.DisplayAlerts = False

Set newWB = Workbooks.Open(filename:=URL, ReadOnly:=True)

On Error Resume Next ' Resume error handling
newWB.SaveAs filename:=LocalPath

' Check if an error occurred during the workbook saving
If Err.Number <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation
Err.Clear
DownloadFile = False
Else
MsgBox "Workbook saved successfully!", vbInformation
DownloadFile = True
End If

newWB.Close
set xl = Nothing
set newWB = Nothing
On Error GoTo 0

End Function

[Bastringue]

Hi, I come back because there is an issue I can't solve. The Copy made here keeps me from seeing the sheets inside
Actually, when I open the new file (by hand), the sheets don't show even though they exist (I see them in the VBA part and their visibility parameter is True).
It looks like I don't close the file correctly after having created it... My last code is here.... hoping someone has already experienced this.

Function DownloadFile(URL As String, LocalPath As String) As Boolean
Dim result As Long
Dim newWB As Workbook
Dim xl As Application

Set xl = CreateObject("Excel.Application")
xl.DisplayAlerts = False

Set newWB = Workbooks.Open(filename:=URL, ReadOnly:=True)

On Error Resume Next
newWB.SaveAs filename:=LocalPath

' Check if an error occurred during the workbook saving
If Err.Number <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation
Err.Clear
DownloadFile = False
Else
MsgBox "Workbook saved successfully!", vbInformation
DownloadFile = True
DoEvents
newWB.Close SaveChanges:=False
Application.Wait Now + TimeValue("00:00:01")
End If
On Error GoTo 0

ThisWorkBook.Activate
set xl = Nothing
set newWB = Nothing

End Function

[Bastringue]

Hi, I come back because there is a small issue I can't solve. The Copy made here keeps me from seeing the sheets inside
Actually, when I open the new file (by hand), the sheets don't show even though they exist (I see them in the VBA part and their visibility parameter is True).
As explained here (https://stackoverflow.com/questions/14691277/excel-wont-show-the-workbooks-worksheets), by hand we must go to '"Affichage" (View ?) and click on "UnHide" and this makes the sheets appear (fine).
Ideally, I would like to toggle this property "On" before I close the file in my code. I have tried something like "newDB.Windows(1).Visible = True " but it didn't work...
Hoping someone has already experienced this.


Function DownloadFile(URL As String, LocalPath As String) As Boolean
Dim result As Long
Dim newWB As Workbook
Dim xl As Application

Set xl = CreateObject("Excel.Application")
xl.DisplayAlerts = False

Set newWB = Workbooks.Open(filename:=URL, ReadOnly:=True)

On Error Resume Next
newWB.SaveAs filename:=LocalPath

' Check if an error occurred during the workbook saving
If Err.Number <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation
Err.Clear
DownloadFile = False
Else
MsgBox "Workbook saved successfully!", vbInformation
DownloadFile = True
DoEvents
newWB.Windows(1).Visible = True
newWB.Close SaveChanges:=True
End If
On Error GoTo 0

ThisWorkBook.Activate
set xl = Nothing
set newWB = Nothing

End Function:)

[Jan Karel Pieterse]

Your code reads:

newDB.Windows(1).Visible = True
I think that shoule be:

newWB.Windows(1).Visible = True

[Bastringue]

Hello Jan, you have a good sight :) but I apologize, it is just a typo in the post that I rectify... the problem is still here... thanks anyway for having seen it...

[Dave]

Hi Bastringue. You are close and Aussiebear provided you with some helpful code which is seems you didn't use? Anyways, change the following part of your code and it should work. HTH. Dave

Dim NewWb As Object, xl As Object
Application.DisplayAlerts = False
Set xl = CreateObject("Excel.Sheet")
Set NewWb = xl.Application.Workbooks.Open(fileName:=URL, ReadOnly:=True)
NewWb.SaveCopyAs fileName:=LocalPath
NewWb.Close SaveChanges:=False
Application.DisplayAlerts = True
Set NewWb = Nothing
Set xl = Nothing