Download Image from a URL with rename issue

[Calltech]

Hello!

I would like to ask for help to a macro issue.

I found a solution to: Download Image from B column to specific path with renamed by A column. Add text to C, if it's successful or not.



Before macro:

[TABLE="width: 650"]
<tbody>[TR]
[TD]PIC NAME[/TD]
[TD]URL[/TD]
[/TR]
[TR]
[TD]350x150[/TD]
[TD]https://placeholdit.imgix.net/~text?
txtsize=33&txt=350%C3%97150&w=350&h=150[/TD]
[/TR]
[TR]
[TD]300x200[/TD]
[TD]https://placeholdit.imgix.net/~text?
txtsize=28&txt=300%C3%97200&w=300&h=200[/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]...[/TD]
[/TR]
</tbody>[/TABLE]



After macro:

[TABLE="width: 850"]
<tbody>[TR]
[TD]PIC NAME[/TD]
[TD]URL[/TD]
[TD]Status[/TD]
[/TR]
[TR]
[TD]350x150[/TD]
[TD]https://placeholdit.imgix.net/~text?
txtsize=33&txt=350%C3%97150&w=350&h=150[/TD]
[TD]File successfully downloaded[/TD]
[/TR]
[TR]
[TD]300x200[/TD]
[TD]https://placeholdit.imgix.net/~text?
txtsize=28&txt=300%C3%97200&w=300&h=200[/TD]
[TD]File successfully downloaded[/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]...[/TD]
[TD]...[/TD]
[/TR]
</tbody>[/TABLE]

Here is the macro:

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">Option Explicit

PrivateDeclareFunction URLDownloadToFile Lib"urlmon" _
Alias"URLDownloadToFileA"(ByVal pCaller AsLong, _
ByVal szURL AsString,ByVal szFileName AsString, _
ByVal dwReserved AsLong,ByVal lpfnCB AsLong)AsLong

Dim Ret AsLong

'~~> This is where the images will be saved. Change as applicable
Const FolderName AsString="C:\Temp"

Sub Sample()
Dim ws As Worksheet
Dim LastRow AsLong, i AsLong
Dim strPath AsString

'~~> Name of the sheet which has the list
Set ws = Sheets("Sheet1")

LastRow = ws.Range("A"& Rows.Count).End(xlUp).Row

For i =2To LastRow '<~~ 2 because row 1 has headers
strPath = FolderName & ws.Range("A"& i).Value &".jpg"

Ret = URLDownloadToFile(0, ws.Range("B"& i).Value, strPath,0,0)

If Ret =0Then
ws.Range("C"& i).Value ="File successfully downloaded"
Else
ws.Range("C"& i).Value ="Unable to download the file"
EndIf
Next i
EndSub

</code>

Many people has error with this macro:

Compile error: The code in this project must be updated for use on64-bit systems.




The solution if change the macro codes to it:

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">Option Explicit

PrivateDeclareFunction URLDownloadToFile Lib"urlmon" _
Alias"URLDownloadToFileA"(ByVal pCaller AsLong, _
ByVal szURL AsString,ByVal szFileName AsString, _
ByVal dwReserved AsLong,ByVal lpfnCB AsLong)AsLong

Dim Ret AsLong

'~~> This is where the images will be saved. Change as applicable
Const FolderName AsString="C:\Temp"



</code>But I still have a continue error:

I would like to ask for help why can't working this macro for me?
I tried to change the URLDownloadToFile code row to others still unsuccessfully.

Thank you all in advance for your help!

Calltech

 

[Ruddles]

The code you've posted is missing a lot of spaces which make it incorrect: PrivateDeclareFunction, AsLong and AsString - these have all lost space characters (Private Declare Function, As Long and As String).

The code you're actually running, does that have spaces in all the correct places or is it exactly the same as you've posted?

 

[Ruddles]

This works for me:-

Option Explicit

Private Declare 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 Long

Dim Ret As Long

[COLOR=#008000]'~~> This is where the images will be saved. Change as applicable
[/COLOR]Const FolderName As String = "C:\Temp\"

Sub Sample()

  Dim ws As Worksheet
  Dim LastRow As Long, i As Long
  Dim strPath As String
  
  '~[COLOR=#008000]~> Name of the sheet which has the list
[/COLOR]  Set ws = Sheets("Sheet1")
  
  LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
  
  For i = 2 To LastRow '<~[COLOR=#008000]~ 2 because row 1 has headers[/COLOR]
    strPath = FolderName & ws.Range("A" & i).Value & ".jpg"
    Ret = URLDownloadToFile(0, ws.Range("B" & i).Value, strPath, 0, 0)
    If Ret = 0 Then
      ws.Range("C" & i).Value = "File successfully downloaded"
    Else
      ws.Range("C" & i).Value = "Unable to download the file"
    End If
  Next i
  
End Sub

(I had to add the trailing backslash in FolderName.)

 

[Ruddles]

And I would maybe add this line of code to clear your results column immediately after LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row:-

  ws.Range("C2:C" & LastRow).ClearContents

 

[Calltech]

Sorry I copied a bad changes.

Option Explicit


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


Dim Ret As Long


'~~> This is where the images will be saved. Change as applicable
Const FolderName As String = "C:\Temp"


The original code working with Microsoft Office 2010 x64bit. So this must be change to who has a Microsoft Office 2010 x32bit.

I use Microsoft Office Professional Plus 2013 64bit, but I tried with Microsoft Office 2010 x32bit and not worked.

 

[Calltech]

Yes it's look like! -> Const FolderName As String = "C:\Temp"
But in the forum must add \\ after Temp to show -> Const FolderName As String = "C:\Temp\"


During I fixed the links with MicrosoftEasyFix50655.msi
Now if I click the link it's loading on browser, but the problem not solved.