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
Related
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
How can I get the byte array of the opened Word Document (.docm) without saving it to a local drive first.
The document will be opened on a Thin Client without any local drive from SharePoint. When the user want to save the changes, I need to send the byte array to a web-service to process it. (Not back to SharePoint).
Dim filePath As String
Dim fileName As String
Dim fullFileName As String
filePath = ThisDocument.path
fileName = ThisDocument.Name
fullFileName = filePath + "/" + fileName
the value of filePath is 'http://webiste/application'
the value of fileName is 'theOpenFileName.docm'
the value of fullFileName is 'http://webiste/application/theOpenFileName.docm'
How can I get the whole file as a byte array so I can send it to the web-service like this:
Dim bytFile() As Byte
Dim http
Dim userName As String
Dim url As String
Set http = CreateObject("MSXML2.ServerXMLHTTP")
userName = "Me"
'--- read file
bytFile = ??????????
'--- send the file to the API server
url = "http://localhost/DocWebApi/Post?fileName=" & fileName & "&userName=" & userName
http.Open "POST", url, False
http.Send (bytFile)
http.waitForResponse 4000
Thanks in advance!
Try the next approach, please:
Sub testByteArray()
Dim bytFile() As Byte, strDocShare As String
Dim fileDoc As Integer: fileDoc = FreeFile
strDocShare = Application.GetOpenFilename("Office Documents (*.docm),*.docm", , "Please select document to be processed...")
If strDocShare = False Then Exit Sub 'If no document has been selected
Open strDocShare For Binary Access Read As #fileDoc
ReDim bytFile(0 To LOF(fileDoc) - 1)
Get #fileDoc, , bytFile
Close #fileDoc
End Sub
If the document will be open, the above code may return an error. A method to determine if a shared document/workbook is open by other user, uses some similar code and catches the error...
I've written a script in vba to download different movie posters from a torrent site and embed them in a spreadsheet right next to its concerning movies. My script can parse the movie names in a spreadsheet and download & save the images in a folder. What I can't do is place the downloaded images next to each movie name in a spreadsheet.
How can I place the movie posters in concerning cells right next to each movie name?
My script so far:
Sub DownloadAndEmbedImages()
'customized directory location within double quotes
Const strPath$ = "C:\Users\WCS\Desktop\Test\"
Dim Http As New XMLHTTP60, Html As New HTMLDocument
Dim post As Object, imgArr As Variant, R&
'check out if the folder is empty. If not empty, delete them to download anew
If Dir(strPath & "*.*") <> "" Then Kill strPath & "*.*"
With Http
.Open "GET", "https://yts.am/browse-movies", False
.send
Html.body.innerHTML = .responseText
End With
For Each post In Html.getElementsByClassName("img-responsive")
R = R + 1: Sheets("Sheet1").Cells(R, 1) = post.alt
imgArr = Split(post.src, "/")
imgArr = imgArr(UBound(imgArr) - 1) & ".jpg"
Http.Open "GET", post.src, False
Http.send
With CreateObject("ADODB.Stream")
.Open
.Type = 1
.write Http.responseBody
.SaveToFile (strPath & imgArr)
.Close
End With
Next post
End Sub
Referenece to add to execute the above script:
Microsoft XML, v6.0
Microsoft HTML Object library
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);
How Can i save a webpage source html dynamically using VBA in my local machine?
Thanks,
Arup
This is a simple way of getting and saving an html file to your temp folder for working on. It requires a reference to either Microsoft XML 3.0 or Microsoft XML 6.0.
Sub GetHTTP()
Dim objHttp As Object
Dim CachedFilePath As String
Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
Call objHttp.Open("GET", "http://www.example.com/", False)
Call objHttp.Send("")
CachedFilePath = Environ("temp") & "\" & "ReplaceThisWithFilename" & ".html"
Call CreateFile(CachedFilePath, objHttp.ResponseText)
End Sub
Function CreateFile(FileName As String, Contents As String) As String
' creates file from string contents
Dim tempFile As String
Dim nextFileNum As Long
nextFileNum = FreeFile
tempFile = FileName
Open tempFile For Output As #nextFileNum
Print #nextFileNum, Contents
Close #nextFileNum
CreateFile = tempFile
End Function
To delete the file when you're finished with it try:
Sub DeleteFile(ByVal FileToDelete As String)
SetAttr FileToDelete, vbNormal
Kill FileToDelete
End Sub