0

I am using the following VBA code to download images. The URLs are from my client.
It works for almost all the URLs like https://www.fleur-ami.com/out/pictures/master/product/1/sofa-samt-olive-josephine-tingo-living-24111.jpg

There are some URLs with special characters like "ä" and/or "ß". https://www.fleur-ami.com/out/pictures/master/product/1/bodengef%C3%A4%C3%9F-XXL-anthrazit-tribeca-shape-natural-raw-24541-N.jpg
For these URLs the image is not downloaded. You can try it, Password and username is not neccessary.

Sub downloadimage ()

    Dim myURL As String
    Dim i As Integer
    Dim j As Integer
    
    lRow = Worksheets("datenabruf").Cells(Rows.Count, 1).End(xlUp).Row
    'Worksheets("datenabruf").Range("cv1:dg" & lRow).ClearContents
    
    For j = 46 To 57
        For i = 2 To lRow
    
            artikelnummer = Worksheets("datenabruf").Cells(i, 1)
            myURL = Worksheets("datenabruf").Cells(i, j)
            If myURL <> "" Then
                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
                    If j = 46 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-1.jpg"
                        Worksheets("datenabruf").Cells(i, 100) = artikelnummer & "-1.jpg"
                    ElseIf j = 47 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-2.jpg"
                        Worksheets("datenabruf").Cells(i, 101) = artikelnummer & "-2.jpg"
                    ElseIf j = 48 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-3.jpg"
                        Worksheets("datenabruf").Cells(i, 102) = artikelnummer & "-3.jpg"
                    ElseIf j = 49 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-4.jpg"
                        Worksheets("datenabruf").Cells(i, 103) = artikelnummer & "-4.jpg"
                    ElseIf j = 50 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-5.jpg"
                        Worksheets("datenabruf").Cells(i, 104) = artikelnummer & "-5.jpg"
                    ElseIf j = 51 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-6.jpg"
                        Worksheets("datenabruf").Cells(i, 105) = artikelnummer & "-6.jpg"
                    ElseIf j = 52 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-7.jpg"
                        Worksheets("datenabruf").Cells(i, 106) = artikelnummer & "-7.jpg"
                    ElseIf j = 53 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-8.jpg"
                        Worksheets("datenabruf").Cells(i, 107) = artikelnummer & "-8.jpg"
                    ElseIf j = 54 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-9.jpg"
                        Worksheets("datenabruf").Cells(i, 108) = artikelnummer & "-9.jpg"
                    ElseIf j = 55 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-10.jpg"
                        Worksheets("datenabruf").Cells(i, 109) = artikelnummer & "-10.jpg"
                    ElseIf j = 56 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-11.jpg"
                        Worksheets("datenabruf").Cells(i, 110) = artikelnummer & "-11.jpg"
                    ElseIf j = 57 Then
                        zieladresse = "Z:\fleurami\bilder\api2.0\" & artikelnummer & "-12.jpg"
                        Worksheets("datenabruf").Cells(i, 111) = artikelnummer & "-12.jpg"
                    End If
                    
                    oStrm.SaveToFile zieladresse, 2 ' 1 = no overwrite, 2 = overwrite
                    oStrm.Close
                End If
            End If
        Next i
    Next j
    
    Worksheets("datenabruf").Cells(1, 100) = "Bild 1"
    Worksheets("datenabruf").Cells(1, 101) = "Bild 2"
    Worksheets("datenabruf").Cells(1, 102) = "Bild 3"
    Worksheets("datenabruf").Cells(1, 103) = "Bild 4"
    Worksheets("datenabruf").Cells(1, 104) = "Bild 5"
    Worksheets("datenabruf").Cells(1, 105) = "Bild 6"
    Worksheets("datenabruf").Cells(1, 106) = "Bild 7"
    Worksheets("datenabruf").Cells(1, 107) = "Bild 8"
    Worksheets("datenabruf").Cells(1, 108) = "Bild 9"
    Worksheets("datenabruf").Cells(1, 109) = "Bild 10"
    Worksheets("datenabruf").Cells(1, 110) = "Bild 11"
    Worksheets("datenabruf").Cells(1, 111) = "Bild 12"

End Sub
Community
  • 1
  • 1
Phil
  • 31
  • 4
  • Does this answer your question? [How can I URL encode a string in Excel VBA?](https://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba) – Toddleson Dec 19 '22 at 21:28
  • Links work for me. `File.Open "GET", "https://www.fleur-ami.com/out/pictures/master/product/1/bodengef%C3%A4%C3%9F-XXL-anthrazit-tribeca-shape-natural-raw-24541-N.jpg", False`. What is with the user name and password? I add I user agent string `File.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 6.0; Trident/4.0; SLCC1; .NET CLR 2.0.50727; Media Center PC 5.0; .NET CLR 1.1.4322; .NET CLR 3.5.30729; .NET CLR 3.0.30618; .NET4.0C; .NET4.0E; BCD2000; BCD2000)" 'This is IE 8 headers`. – Lundt Dec 19 '22 at 23:18
  • Are the special characters already encoded in the URL's on your worksheet? – Tim Williams Dec 19 '22 at 23:41
  • @ Tim Williams The special characters are not encoded in the URL´s on my worksheet. That is the problem. – Phil Dec 20 '22 at 14:21
  • @Lundt the URL https://www.fleur-ami.com/out/pictures/master/product/1/bodengef%C3%A4%C3%9F-XXL-anthrazit-tribeca-shape-natural-raw-24541-N.jpg works fine. But in my list the URL is https://www.fleur-ami.com/out/pictures/master/product/1/bodengefäß-XXL-anthrazit-tribeca-shape-natural-raw-24541-N.jpg it contains the special character "ä" and "ß". With the special character in the URL the macro does not download the image. – Phil Dec 20 '22 at 14:31
  • I added `If InStr(myURL, "ä") > 0 Then myURL = Replace(myURL, "ä", "%C3%A4") End If If InStr(myURL, "ß") > 0 Then myURL = Replace(myURL, "ß", "%C3%9F") End If If InStr(myURL, "ü") > 0 Then myURL = Replace(myURL, "ü", "%C3%BC") End If ` to the macro to replace the special characters. Not elegant but it works. – Phil Dec 20 '22 at 17:30
  • Did you try the link posted by Toddleson? – Tim Williams Dec 20 '22 at 17:40
  • @ Tim Williams I tried the link posted by Toddleson. Using that function a link like [link](https://www.fleur-ami.com/out/pictures/master/product/1/pflanzgefaess-olivgrau-concrete-conical-27799.jpg) is transformed to [link](https%3A%2F%2Fwww.fleur-ami.com%2Fout%2Fpictures%2Fmaster%2Fproduct%2F1%2Fpflanzgefaess-olivgrau-concrete-conical-27799.jpg) when you try to open that transformed link in a browser it does not work. in my macro I got the message "the method open for the object IServerXMLHTTPRequest2" does not work. – Phil Dec 21 '22 at 10:36

1 Answers1

1

If all your URL have the same pattern and you only need to URLencode the last part:

Sub Tester()

    Dim url, arr
    url = "https://www.fleur-ami.com/out/pictures/master/product/1/bodengefäß-XXL-anthrazit-tribeca-shape-natural-raw-24541-N.jpg"
    
    arr = Split(url, "/product/1/")
    
    If UBound(arr) = 1 Then
        url = arr(0) & "/product/1/" & Application.EncodeURL(arr(1))
        '>> https://www.fleur-ami.com/out/pictures/master/product/1/bodengef%C3%A4%C3%9F-XXL-anthrazit-tribeca-shape-natural-raw-24541-N.jpg

        Debug.Print url
    End If
        
End Sub
Tim Williams
  • 154,628
  • 8
  • 97
  • 125