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
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
I've create a macro which is able to parse some movie names from a torrent site.
What I want to do now is (My script can satisfy the first three requirements already except the fourth one):
1. Create a folder in my desktop
2. Create a new workbook after the name of the `Genre`
3. write the data in that new workbook
4. Save and close the data-ridden workbook in the newly created folder
This is my try so far:
Sub CreateAndSaveWorbook()
Const link = "https://yts.am/browse-movies/0/all/action/0/latest"
Dim Http As New XMLHTTP60, Html As New HTMLDocument, genre$
Dim post As HTMLDivElement, wb As Workbook
Dim daddr$, fdObj As Object
daddr = Environ("USERPROFILE") & "\Desktop\Test\"
Set fdObj = CreateObject("Scripting.FileSystemObject")
If Not fdObj.FolderExists(daddr) Then fdObj.CreateFolder (daddr)
With Http
.Open "GET", link, False
.send
Html.body.innerHTML = .responseText
End With
genre = Html.querySelector("select[name='genre'] option[value='action']").innerText
Set wb = Workbooks.Add
wb.SaveAs daddr & genre & ".xlsx"
For Each post In Html.getElementsByClassName("browse-movie-bottom")
R = R + 1: wb.Sheets(1).Cells(R, 1) = post.getElementsByClassName("browse-movie-title")(0).innerText
Next post
End Sub
How can I save and close a newly created workbook in a customized folder?
Here's your answer :) :Change wb.saveAs to wb.Close true, daddr & genre & ".xlsx"
I have an Excel doc with Google's drive hyperlinks to photos, I want to change these to link local photos I downloaded in a folder instead. Is this possible without having to do it manually ?
Hyperlink : https://drive.google.com/open?id=1yCSptfKRkbkN39Lkbz2yXLM0CI332_DC
Image name : _storage_emulated_0_odk_instances_CASA_2018-06-22_15-29-52_1529678182622.jpg
It looks to me like you are using shareable links from Google drive - this means that the filename of the images is not visible in the link, and hence you need to uncover the filename by opening the link. We can do this in VBA by invoking a browser object, here, using Internet Explorer:
Sub GetFileName()
Dim ie As Object
Set ie = CreateObject("Internetexplorer.Application")
ie.Navigate "https://drive.google.com/open?id=1yCSptfKRkbkN39Lkbz2yXLM0CI332_DC"
While ie.busy = True 'Allow the website to load
Application.Wait (Now + TimeValue("0:00:01"))
Wend
Debug.Print (ie.Document.Title)
ie.Quit
End Sub
This gets us the filename /storage/emulated/0/odk/instances/CASA_2018-06-22_15-29-52/1529678182622.jpg for the link you have. As you have stated that the filename on your computer is: _storage_emulated_0_odk_instances_CASA_2018-06-22_15-29-52_1529678182622.jpg, we replace \ with _ using the replace-function. We will also need to remove the " - Google Disk" text from the end of the filename:
Sub GetFileName()
Dim ie As Object
Dim fname As String 'Saving filename as string for later use
Set ie = CreateObject("Internetexplorer.Application")
ie.Navigate "https://drive.google.com/open?id=1yCSptfKRkbkN39Lkbz2yXLM0CI332_DC"
While ie.busy = True 'Allow the website to load the image (wait for 1 second if browser is busy)
Application.Wait (Now + TimeValue("0:00:01"))
Wend
fname = ie.Document.Title
ie.Quit
fname = Replace(fname, "/", "_") 'Changing filename to fit your local file
fname = Replace(fname, " - Google Disk", "") 'Removing the additional text from the filename
Debug.Print (fname)
End Sub
Now that we have that working, we can loop through the region in your excel sheet where you have the hyperlinks saved. We will also make sure that Excel recognises the paths to the local file as a hyperlink, using Hyperlinks.Add:
Sub GetFileName()
Dim ie As Object
Dim fname As String, wlink As String, lpath As String
lpath = "C:\Users\LocalAccount\Downloads\" 'The folder where you have the images saved
Set ie = CreateObject("Internetexplorer.Application")
For i = 1 To 10 'Replace 1 and 10 with your first and last row of hyperlinks
wlink = Cells(i, 2).Value 'My links are in column B, hence "2". Change this to fit your sheet (1 for column A, 3 for Column C, etc.)
ie.Navigate wlink
While ie.busy = True 'Allow the website to load the image (wait for 1 second if browser is busy)
Application.Wait (Now + TimeValue("0:00:01"))
Wend
fname = ie.Document.Title
fname = Replace(fname, "/", "_")
fname = Replace(fname, " - Google Disk", "") 'Removing the additional text from the filename
fname = lpath + fname
Cells(i, 2).Value = fname 'Replaces the hyperlink with the local filename
Cells(i, 2).Hyperlinks.Add Cells(i, 2), Cells(i, 2).Value
Next i
ie.Quit
End Sub
This should solve your problem - let me know if you have any troubles.
PS: Remember to set the lpath variable to the folder path where you have the local images
I have a large list of hyperlinks (plus a few cells of nonsense) that I need to check. I need to know which links are still active and which no longer exist or return a 404 (or other) Error. I have been using the advice in this entry: Sort dead hyperlinks in Excel with VBA? and it worked great in a small selection of links, some of which I deliberately broke myself. However, now that I try to use the same macro on my actual list of hyperlinks it won't work at all! I've manually checked a few and have found links with 404 errors. Again, when I deliberately mistype one of the addresses it will pick that up but it won't pick up any in the list that were broken already.
I'm totally new to macros and am really stumbling about in the dark here. Any help/advice would be very much appreciated!
I've been using this for a while and it has been working for me.
Sub Audit_WorkSheet_For_Broken_Links()
If MsgBox("Is the Active Sheet a Sheet with Hyperlinks You Would Like to Check?", vbOKCancel) = vbCancel Then
Exit Sub
End If
On Error Resume Next
For Each alink In Cells.Hyperlinks
strURL = alink.Address
If Left(strURL, 4) <> "http" Then
strURL = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base") & strURL
End If
Application.StatusBar = "Testing Link: " & strURL
Set objhttp = CreateObject("MSXML2.XMLHTTP")
objhttp.Open "HEAD", strURL, False
objhttp.Send
If objhttp.statustext <> "OK" Then
alink.Parent.Interior.Color = 255
End If
Next alink
Application.StatusBar = False
On Error GoTo 0
MsgBox ("Checking Complete!" & vbCrLf & vbCrLf & "Cells With Broken or Suspect Links are Highlighted in RED.")
End Sub
Specify an actual address in place of alink or define alink as a variable which contains a web address.
variable definitions missing, URL to working code below
Dim alink As Hyperlink
Dim strURL As String
Dim objhttp As Object
Bulk Url checker macro excel
I have been using the suggested code above. I had to adapt it further so that it can differentiate between a URL and a File as I have both in my excel spreadsheet. It works well for my particular spreadsheet with about 50 links to files and URLs.
Sub Audit_WorkSheet_For_Broken_Links()
If MsgBox("Is the Active Sheet a Sheet with Hyperlinks You Would Like to Check?", vbOKCancel) = vbCancel Then
Exit Sub
End If
Dim alink As Hyperlink
Dim strURL As String
Dim objhttp As Object
Dim count As Integer
On Error Resume Next
count = 0 'used to track the number of non-working links
For Each alink In Cells.Hyperlinks
strURL = alink.Address
If Left(strURL, 4) <> "http" Then
strURL = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base") & strURL
End If
Application.StatusBar = "Testing Link: " & strURL
Set objhttp = CreateObject("MSXML2.XMLHTTP")
objhttp.Open "HEAD", strURL, False
objhttp.Send
If objhttp.statustext = "OK" Then 'if url does exist
alink.Parent.Interior.ColorIndex = 0 'clear cell color formatting
ElseIf objhttp.statustext <> "OK" Then 'if url doesn't exist
If Dir(strURL) = "" Then 'check if the file exists
alink.Parent.Interior.Color = 255 'set cell background to red its not a valid file or URL
count = count + 1 'update the count of bad cell links
Else
alink.Parent.Interior.ColorIndex = 0 'clear cell color formatting
End If
End If
Next alink
Application.StatusBar = False
'Release objects to prevent memory issues
Set alink = Nothing
Set objhttp = Nothing
On Error GoTo 0
MsgBox ("Checking Complete!" & vbCrLf & vbCrLf & count & " Cell(s) With Broken or Suspect Links. Errors are Highlighted in RED.")
End Sub
I hope this helps someone else as much as it has helped me... A little better everyday!
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);