I'm trying to save a file from https password protected site using WinHTTP. Here's the code:
Sub SaveFileFromURL()
Dim FileNum As Long
Dim FileData() As Byte
Dim WHTTP As Object
fileUrl = "https://www.website.com/dir1/dir2/file.xls"
filePath = "C:\myfile.xls"
myuser = "username"
mypass = "password"
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
WHTTP.Open "GET", fileUrl, False
WHTTP.SetCredentials myuser, mypass, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
WHTTP.Send
FileData = WHTTP.ResponseBody
Set WHTTP = Nothing
FileNum = FreeFile
Open filePath For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
MsgBox "File has been saved!", vbInformation, "Success"
End Sub
The problem is with authentication. The file is being saved but when I open it in Excel it's just the html logon page instead of the actual file. If I copy direct file url and paste it into browser addressbar and I'm not logged in to the webpage the effect is the same. I'm presented with the logon page. Then if I enter my login and password the download window will show up allowing me to save the file.
So I think that SetCredentials part of the code is not working properly cause if I debug.print WHTTP.ResponseBody it's html code instead of the acutal file data.
Is there a way to pass userid and password to the WinHTTP so I could be able to properly save the file?
Here's the page address:
https://sst.msde.state.md.us/
=======================EDIT:========================
So I've played a little bit with it today and I think I'm moving forward. Here's what I got. I Modyfied the code like this:
Sub SaveFileFromURL()
Dim FileNum As Long
Dim FileData() As Byte
Dim WHTTP As Object
fileUrl = "https://www.website.com/dir1/dir2/file.xls"
filePath = "C:\myfile.xls"
myuser = "username"
mypass = "password"
strAuthenticate = "start-url=%2F&user=" & myuser & "&password=" & mypass & "&switch=Log+In"
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
WHTTP.Open "POST", fileUrl, False
WHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
WHTTP.Send strAuthenticate
WHTTP.Open "GET", fileUrl, False
WHTTP.Send
Debug.Print WHTTP.GetAllResponseHeaders()
FileData = WHTTP.ResponseBody
Set WHTTP = Nothing
FileNum = FreeFile
Open filePath For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
MsgBox "File has been saved!", vbInformation, "Success"
End Sub
When I Debug.Print WHTTP.GetAllResponseHeaders() I get e.g.:
Accept-Ranges: bytes
Content-Disposition: attachement; filename="xxx"
Content-Length: xxxxxx
Content-Type: application/octet-stream
So I think that authentication worked but I still cannot save the file. When I continue with:
FileData = WHTTP.ResponseBody
Set WHTTP = Nothing
FileNum = FreeFile
Open filePath For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
The content of the saved file is the html webpage itself, but not the file.
Did I do the authentication rigth and the problem is with saving the file to the disk or still is there a problem with authentication and that's why I cannot save it? Any clues?
Ok, I did it. Here the code:
Sub SaveFileFromURL()
Dim FileNum As Long
Dim FileData() As Byte
Dim WHTTP As Object
mainUrl = "https://www.website.com/"
fileUrl = "https://www.website.com/dir1/dir2/file.xls"
filePath = "C:\myfile.xls"
myuser = "username"
mypass = "password"
'#David Zemens, I got this by examining webpage code using Chrome, thanks!
strAuthenticate = "start-url=%2F&user=" & myuser & "&password=" & mypass & "&switch=Log+In"
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
'I figured out that you have to POST authentication string to the main website address not to the direct file address
WHTTP.Open "POST", mainUrl, False 'WHTTP.Open "POST", fileUrl, False
WHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
WHTTP.Send strAuthenticate
'Then you have to GET direct file url
WHTTP.Open "GET", fileUrl, False
WHTTP.Send
FileData = WHTTP.ResponseBody
Set WHTTP = Nothing
'Save the file
FileNum = FreeFile
Open filePath For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
MsgBox "File has been saved!", vbInformation, "Success"
End Sub
Thanks for all your help.
BTW I've found this posts very useful:
http://www.mrexcel.com/forum/excel-questions/353006-download-file-excel.html
Not understanding why WinHTTP does NOT authenticate certain HTTPS resource
How to parse line by line WinHTTP response: UTF-8 encoded CSV?
Related
I have an image I get from request.responseBody, how can I pass it to excel without using a temp file in my computer storage?
Details:
I'm using a rest API with the image in the response body
I don't want to have a temp files in my desktop
Challenge is to convert the response from the API to Pictures.Insert or Shapes.AddPicture
I'm using something like this:
Sub GetPicAPI()
Dim myUrl As String ' path of image
Dim myPicture As Picture ' embedded image
Dim MyImage As String ' create string to receive image in text format
Dim myFile As String
Dim datim As String
Set request = CreateObject("MSXML2.ServerXMLHTTP")
datim = Format(CStr(Now), "yyyy_mm_dd_hh_mm_ss") 'datetime to generate file
myFile = Application.DefaultFilePath & "\phototemp" & datim & ".jpeg"
myUrl = "https://images.contoso.com/api/GetPic?pwd=1234=&id=1234res=low"
request.Open "GET", myUrl, False ' Where to get image
request.send ' Send the request for the webpage.
MyImage = StrConv(request.responseBody, vbUnicode) ' Get the webpage response text into response variable.
Open myFile For Output As #1 'open file to save image
Print #1, MyImage 'write to file
Close #1 'close file
Set myPicture = ActiveSheet.Pictures.Insert(myFile) 'put image into cell
End Sub
I have an excel where there are around 30K hyperlinks pointing to a network drive location where all the files are stored. I am trying to create a macro where when i click on the hyperlink it downloads the file to a folder like 'Downloads' where as right now it is just viewing the file in IE.
Have not much idea on macros but have tried using shell app.browseforfolder, FileCopy and URLDownloadToFile but still getting errors.Also have tried using Selection to download selected cells hyperlinks but no dice.
Sample excel file is here: https://filebin.net/06n8hp1wm8y69oqw
Network drive links are like:
\\10.111.11.30\Accounts\EP-D365\39156.jpg
\\10.111.11.30\Accounts\EP-D365\39157.jpg
\\10.111.11.30\Accounts\EP-D365\39158.msg
I managed to put together below code from online resources but doesnt work as it is for download from internet and not network drive local server:
Sub DownloadFile()
Dim WinHttpReq As Object
Dim oStream As Object
Dim myURL As String
Dim LocalFilePath As String
''For Each hlink In ThisWorkbook.Sheets("Main").Hyperlinks
myURL = "\\10.111.11.30\Accounts\EP-D365\39156.jpg"
LocalFilePath = "C:\Users"
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "", ""
WinHttpReq.send
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile LocalFilePath, 2
oStream.Close
End If
''Next
End Sub
Any help appreciated.Thanks.
You can use FileCopy to copy files from a file system - works with UNC pathes. I think your problem comes from the destination - Runtime error 75 is Path/File access error which usually means that the file cannot be written.
I am not 100% sure about all details of FileCopy, but I think you have to give the filename for the destination also - it's different than copy on the command prompt. If you just write the destination folder, you get the error 75 because FileCopy tries to replace the destination folder with the file - which of course doesn't work.
The following code will copy both files from Http and from file system. I did it a little quick&dirty by checking if the path contains a "Slash" or "Backslash" (Mac users will need to find a different attempt). Filename is extracted from the source and glued to the dest folder.
A small advice: Don't hardcode the user path, you can use environ("userprofile") instead.
And one remark: Code will fail if the destination folder does not exist.
Sub test()
Const source = "\\10.111.11.30\Accounts\EP-D365\39156.jpg"
Const url = "https://i.stack.imgur.com/WyPLd.png"
CopyFile source, Environ("TEMP")
CopyFile url, Environ("TEMP")
End Sub
Sub CopyFile(source As String, destPath As String)
If InStr(source, "/") > 0 Then
DownloadFile source, Environ("TEMP")
Else
Dim filename As String, p As Integer
p = InStrRev(source, "\")
filename = Mid(source, p + 1)
FileCopy source, destPath & "\" & filename
End If
End Sub
Sub DownloadFile(url As String, destPath As String)
Dim WinHttpReq As Object
Dim oStream As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", url, False, "", ""
WinHttpReq.send
Dim filename As String, p As Integer
p = InStrRev(url, "/")
filename = Mid(url, p + 1)
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile destPath & "\" & filename, 2
oStream.Close
End If
End Sub
This code creates a download but not of the linked file as it is not direct. When I open the .csv file it downloads, it appears to be the data from the redirect, not the file linked to the redirect.
This is the code:
Sub Asana()
Dim myURL As String
myURL = "https://app.asana.com/-/csv?id=955497629707333"
Dim HttpReq As Object
Set HttpReq = CreateObject("Microsoft.XMLHTTP")
HttpReq.Open "GET", myURL, False, "username", "password"
HttpReq.send
myURL = HttpReq.responseBody
If HttpReq.Status = 200 Then
Set oStrm = CreateObject("ADODB.Stream")
oStrm.Open
oStrm.Type = 1
oStrm.Write HttpReq.responseBody
oStrm.SaveToFile ThisWorkbook.Path & "\" & "SER_Backlog_BRCC.csv", 2 ' 1 = no overwrite, 2 = overwrite
oStrm.Close
End If
End Sub
It should be a spreadsheet copy of the data on the page, but it comes out with data in a spreadsheet of the website and not the linked .csv file you would get, if done manually.
Should be this:
.
I guess, you have an authorization problem, as user/password is not supported by Asana.
You need a Personal Access Token, which has to be set in your request header.
Please replace this line
'Set HttpReq = CreateObject("Microsoft.XMLHTTP")
Set HttpReq = CreateObject("MSXML2.XMLHTTP")
and that line:
'HttpReq.Open "GET", myURL, False, "username", "password"
HttpReq.Open "GET", myURL, False
HttpReq.setRequestHeader "Authorization", "Bearer " & "your Asana token here"
I have searched for a solution to this issue having first researched via Mr Excel and also elsewhere on this site (specifically question 22051960 which appears to be closed to new users like me).
The site I am attempting to download from is :
https://downloads.theice.com/
and it appears that the main site is an html page requesting authorisation credentials.
I have tried the code the above referenced thread which appears to successfully open the main site, authenticate and save the file; however, when I navigate to the file it is not the file on the site but is instead only 1kb and not in excel format. Here is the code from that thread:
Sub SaveFileFromURL()
Dim FileNum As Long
Dim FileData() As Byte
Dim WHTTP As Object
mainUrl = "https://downloads.theice.com/"
fileUrl = "https://downloads.theice.com/Settlement_Reports/Oil/icecleared_oil_2017_01_24.xlsx"
filePath = "C:\mydownloads\myfile2.xls"
myuser = "username"
mypass = "password"
'#David Zemens, I got this by examining webpage code using Chrome, thanks!
strAuthenticate = "start-url=%2F&user=" & myuser & "&password=" & mypass & "&switch=Log+In"
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
'I figured out that you have to POST authentication string to the main website address not to the direct file address
WHTTP.Open "POST", mainUrl, False 'WHTTP.Open "POST", fileUrl, False
WHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
WHTTP.Send strAuthenticate
'Then you have to GET direct file url
WHTTP.Open "GET", fileUrl, False
WHTTP.Send
FileData = WHTTP.ResponseBody
Set WHTTP = Nothing
'Save the file
FileNum = FreeFile
Open filePath For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
MsgBox "File has been saved!", vbInformation, "Success"
End Sub
I have reasonable vba skills within excel but have no experience of html or web-page functionality and so am lost as to how to resolve this issue.
My ultimate aim is to utilise the authentication code within a routine I have written which automatically saves files from a list of URL's in an excel spreadsheet which already works for non-protected url's.
I hope this is an acceptable question for this forum
Many thanks
In my opinion, you should set the credentials (SetCredentials method) before sending your request on your WinHttpRequest instance.
Something like this
WHTTP.SetCredentials(myuser , mypass , HTTPREQUEST_SETCREDENTIALS_FOR_SERVER);
Could you also have a look on below links?
https://msdn.microsoft.com/en-us/library/aa384058(VS.85).aspx
https://msdn.microsoft.com/en-us/library/windows/desktop/aa383144(v=vs.85).aspx
https://msdn.microsoft.com/en-us/library/windows/desktop/aa384076(v=vs.85).aspx
I hope this will help you
I'm trying to make a spreedsheet "upload itself" to a RESTful web service made in Laravel 4.
I have a web form who does the same work, but I need to, instead of make the user go to the web application and manually upload the file, make the sheet capable of upload itself from a click of a button (using macros). I have a method that receives the Input::file('filename') and open the file to read and stuff. I'm using the Microsoft.XMLHTTP VBA object to send the request to the WS. Saddly, I ain't seem to be able to upload the god damm file! I'm sending the path (absolute path) in the post method, but isn't working.
The problem is: How I do this within a VBA code? How do I upload a file to the server through a VBA code? And, if it is possible, how to made that compatible with a laravel application?
EDIT
To proper answer to #Andreyco's question, I'm making this edit.
That's what I receive in the VBA Debug Tool when I return the dump of Input::all()
Array
(
[spreedsheet] => C:\Users\Android\Desktop\tarifa.xls
)
...but, when I receive the response from the web form, it looks like this.
Array
(
[_token] => rvtkLep6rwvkvvXc3u0WoO6nyldylp9xI36n6gb2
[spreedsheet] => Symfony\Component\HttpFoundation\File\UploadedFile Object
(
[test:Symfony\Component\HttpFoundation\File\UploadedFile:private] =>
[originalName:Symfony\Component\HttpFoundation\File\UploadedFile:private] => tarifa.xls
[mimeType:Symfony\Component\HttpFoundation\File\UploadedFile:private] => application/vnd.ms-excel
[size:Symfony\Component\HttpFoundation\File\UploadedFile:private] => 43520
[error:Symfony\Component\HttpFoundation\File\UploadedFile:private] => 0
[pathName:SplFileInfo:private] => /tmp/phpRsX5bf
[fileName:SplFileInfo:private] => phpRsX5bf
)
)
... because of Laravel structure and stuff. Hope it will be useful.
Here a complete, working example. If you do not need the "Please Wait" dialog just use the first code snippet and delete UploadThisFileMain thereof. Also note the server PHP test script at the very end.
Sub UploadThisFileMain()
If ActiveWorkbook.Saved = False Then
MsgBox "This workbook contains unsaved changes. Please save first."
Exit Sub
End If
Dim ret
ret = StartProcessing("File uploading, Please Wait...", "UploadThisFile")
If (ret = True) Then
MsgBox "Upload successful!"
Else
MsgBox "Upload failed: " & ret
End If
End Sub
Private Function UploadThisFile()
Dim bound As String
bound = "A0AD2346-9849-4EF0-9A93-ACFE17910734"
Dim url As String
url = "https://<YourServer>/index.php?id={" & bound & "}"
Dim path As String
path = ThisWorkbook.path & "\" & ThisWorkbook.Name
sMultipart = pvGetFileAsMultipart(path, bound)
On Error Resume Next
Dim r
r = pvPostMultipart(url, sMultipart, bound)
If Err.Number <> 0 Then
UploadThisFile = Err.Description
Err.Clear
Else
UploadThisFile = True
End If
End Function
'sends multipart/form-data To the URL using WinHttprequest/XMLHTTP
'FormData - binary (VT_UI1 | VT_ARRAY) multipart form data
Private Function pvPostMultipart(url, FormData, Boundary)
Dim http 'As New MSXML2.XMLHTTP
'Create XMLHTTP/ServerXMLHTTP/WinHttprequest object
'You can use any of these three objects.
'Set http = CreateObject("WinHttp.WinHttprequest.5")
'Set http = CreateObject("MSXML2.XMLHTTP")
Set http = CreateObject("MSXML2.ServerXMLHTTP")
'Open URL As POST request
http.Open "POST", url, False
'Set Content-Type header
http.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + Boundary
'Send the form data To URL As POST binary request
http.send FormData
'Get a result of the script which has received upload
pvPostMultipart = http.responseText
End Function
Private Function pvGetFileAsMultipart(sFileName As String, Boundary As String) As Byte()
Dim nFile As Integer
Dim sPostData As String
'--- read file
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'--- prepare body
sPostData = "--" & Boundary & vbCrLf & _
"Content-Disposition: form-data; name=""uploadfile""; filename=""" & Mid$(sFileName, InStrRev(sFileName, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
sPostData & vbCrLf & _
"--" & Boundary & "--"
'--- post
pvGetFileAsMultipart = pvToByteArray(sPostData)
End Function
Private Function pvToByteArray(sText As String) As Byte()
pvToByteArray = StrConv(sText, vbFromUnicode)
End Function
Create a new module Processing_Code:
Public Processing_Message As String
Public Macro_to_Process As String
Public Return_Value As String
Function StartProcessing(msg As String, code As String)
Processing_Message = msg 'Set the message that is displayed
'in the dialog box
Macro_to_Process = code 'Set the macro that is run after the
'dialog box is active
Processing_Dialog.Show 'Show the Dialog box
StartProcessing = Return_Value
End Function
Create a form Processing_Dialog. Set StartUpPosition to 2 - CenterScreen. Add code:
Private Sub UserForm_Initialize()
lblMessage.Caption = Processing_Message 'Change the Label
'Caption
End Sub
Private Sub UserForm_Activate()
Me.Repaint 'Refresh the UserForm
Return_Value = Application.Run(Macro_to_Process) 'Run the macro
Unload Me 'Unload the UserForm
End Sub
Now add a button to your Worksheet (If there is no "Developer" tab, go to "Options" -> "Customize Ribbon" -> enable checkbox "Developer") and assign macro UploadThisFileMain.
For the server part use this PHP test script:
<?php
foreach (getallheaders() as $name => $value) {
echo "$name: $value\n";
}
echo "POST:";
print_r($_POST);
echo "GET:";
print_r($_GET);
echo "FILES:";
print_r($_FILES);
$entityBody = file_get_contents('php://input');
echo "Body:$entityBody";
exit;
$base_dir = dirname( __FILE__ ) . '/upload/';
if(!is_dir($base_dir))
mkdir($base_dir, 0777);
move_uploaded_file($_FILES["uploadfile"]["tmp_name"], $base_dir . '/' . $_FILES["uploadfile"]["name"]);
?>
Sources:
https://wqweto.wordpress.com/2011/07/12/vb6-using-wininet-to-post-binary-file/
http://www.motobit.com/tips/detpg_post-binary-data-url/
http://fm4dd.com/programming/shell/microsoft-vbs-https-upload.htm
https://support.microsoft.com/en-us/kb/162257
I just figure it out in the follow
IT Blog and it served me "like a glove"! Just two simple VBA functions/methods that did the job so f**king well! I Just needed to pass the file and the URL and it was done!
Thanks #Andreyco for your help! ;)
Simply posting file directly as binary body:
Sub UploadThisFile()
Range("A1").Select
ActiveCell.FormulaR1C1 = "LOADING..."
Dim url As String
url = "https://<YourServer>/index.php"
Dim path As String
path = ThisWorkbook.path & "\" & ThisWorkbook.Name
sData = pvGetFileAsData(path)
mimeType = "application/vnd.ms-excel.sheet.macroEnabled.12"
On Error Resume Next
Dim r
r = pvPost(url, mimeType, sData)
Range("A1").Select
If Err.Number <> 0 Then
ActiveCell.FormulaR1C1 = "Upload failed: " & Err.Description
Err.Clear
Else
ActiveCell.FormulaR1C1 = r
End If
End Sub
Private Function pvPost(url, mimeType, body)
Dim http 'As New MSXML2.XMLHTTP
Set http = CreateObject("MSXML2.ServerXMLHTTP")
http.Open "POST", url, False
http.setRequestHeader "Content-Type", mimeType
http.send body
pvPost = http.responseText
End Function
Private Function pvGetFileAsData(sFileName As String) As Byte()
Dim nFile As Integer
Dim sPostData As String
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
pvGetFileAsData = baBuffer
End If
Close nFile
End Function
Store file on server side via PHP script:
$entityBody = file_get_contents('php://input');
file_put_contents('file.xlsm', $entityBody);