Soru İnternet Linkinden Resim Çağırma

[vurkan]

Arkadaşlar merhaba;

Yaklaşık 20000 satırlık bir dosya için yardımınıza ihtiyacım var. Bu çalışmamda;

1-) Q sütunuda internbet linki bulunan resimleri D sütununa getirmek istiyorum.
2-) Ayrıca bu adreslerdeki resimler mesela daha sonra kullanılmak üzere her resim E sütunundaki kodlarla isimlendirilerek RESİMLER isimli bir klasöre farklı kaydetle kopyalanabilir mi? Bunun için nasıl bir kod yazılmalıdır? Saygılar.

İndir RESİM ALMA

Dosyayı indir RESİM ALMA

dosya.co

 

[vurkan]

Arkadaşlar konu ile ilgili bir fikri olan yok mu acaba?

 

[Haluk]

site: excel.web.tr haluk internetten resim - Google Search

.

 

[vurkan]

Haluk Üstadım. Verdiğiniz linkte altın üye olmadığımdan maalesef hiçbir koda ulaşamadım. 2 nolu mesajdaki dosyanın kodlarına nasıl ulaşabilirim? Yardımcı olabilir misiniz? Saygılar.

 

[askm]

Aşağıdaki kodları deneyin.

Sub Resim_Indir()
Dim i As Integer

Dim DosyaYolu As String
Dim son As Long
son = Range("Q" & Rows.Count).End(3).Row
DosyaYolu = ThisWorkbook.Path & "\RESİMLER\"
basla = Timer

On Error Resume Next
    For i = 2 To son
        If Cells(i, "Q") <> Empty Then
            URL$ = Cells(i, "Q").Value
            dosya$ = DosyaYolu & Cells(i, "E") & ".jpg"
            DownloadFile URL$, dosya$
        End If
    Next i
    bitir = Timer - basla
    MsgBox "İndirme işlemi " & Format(bitir, "00:00:00.00") & " süresinde tamamlanmıştır. ", _
     vbInformation + vbMsgBoxRtlReading, "Www.ExcelVBA.Net"
    i = Empty
End Sub

Function DownloadFile(ByVal URL$, ByVal LocalPath$) As Boolean
    Dim XMLHTTP, ADOStream, FileName
    On Error Resume Next: Kill LocalPath$
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "GET", Replace(URL$, "\", "/"), "False"
    XMLHTTP.send
    
    Set ADOStream = CreateObject("ADODB.Stream")
    ADOStream.Type = 1: ADOStream.Open
    ADOStream.Write XMLHTTP.responseBody
    ADOStream.SaveToFile LocalPath$, 2
    ADOStream.Close: Set ADOStream = Nothing
    DownloadFile = True
    Set XMLHTTP = Nothing
End Function

 

[vurkan]

Sayın Askm. Verdiğiniz kod çalıştı. Ancak Q sütununda resim linki olmayan ve #YOK şeklinde olan satırlar var. verdiğiniz kod bu satırlar için bir üst satırda bulunan resim linkini kullanarak aynı resmi indirdi. Oysa #YOK şeklinde olan satırlardaki ürün kodlarının resmi yok. Yani bu satırlar için bir indirme yapmamalıydı. Bunu nasıl sağlarız? Saygılar.

 

[askm]

Kodları aşağıdaki gibi değiştirin. Function aynı kalsın.

Sub Resim_Indir()
Dim i As Integer

Dim DosyaYolu As String
Dim son As Long
son = Range("Q" & Rows.Count).End(3).Row
DosyaYolu = ThisWorkbook.Path & "\RESİMLER\"
basla = Timer

On Error Resume Next
    For i = 2 To son
        If Cells(i, "Q") <> Empty And Left(Cells(i, "Q"), 4) = "http" Then
            URL$ = Cells(i, "Q").Value
            dosya$ = DosyaYolu & Cells(i, "E") & ".jpg"
            DownloadFile URL$, dosya$
            URL$ = Empty
        End If
    Next i
    bitir = Timer - basla
    MsgBox "İndirme işlemi " & Format(bitir, "00:00:00.00") & " süresinde tamamlanmıştır. ", _
     vbInformation + vbMsgBoxRtlReading, "Www.ExcelVBA.Net"
    i = Empty
End Sub

 

[vurkan]

Sayın Askm. Dediğiniz şekilde dosyama uyarladığım da #YOK şeklinde olan satırlar için resim indirmedi ancak jpg uzantılı 0 bayt olan ve E deki ürün kodunun ismini alan bir dosya oluşturdu. Resimleri dosyaya çağırdığımda o satırlarda resim görüntülenemiyor. şeklinde boş bir çerçeve ekliyor. İnternet adresi olmayan satırlar için boş bırakabilir miyiz acaba? Saygılar

 

[vurkan]

Arkadaşlar Merhaba Sayın Askm'nin son verdiği kod üzerinde nasıl bir değişiklik yapılmalı ki İnternet adresi olmayan satırlar için resim dosyaları oluşturmasın? Saygılar.

İndir RESİM İNDİRME

Dosyayı indir RESİM İNDİRME

dosya.co

(dosyanın bulunduğu yerde RESİMLER isinli bir klasör var)

 

[askm]

Aşağıdaki kodları deneyin.

Sub Resim_Indir()
Dim i As Integer

Dim DosyaYolu As String
Dim link As String
Dim son As Long
son = Range("Q" & Rows.Count).End(3).Row
DosyaYolu = ThisWorkbook.Path & "\RESİMLER\"
basla = Timer

On Error Resume Next
    For i = 2 To son
        link = Cells(i, "Q").Value
        If InStr(1, link, "http") > 0 Then
            URL$ = Cells(i, "Q").Value
            dosya$ = DosyaYolu & Cells(i, "E") & ".jpg"
            DownloadFile URL$, dosya$
            URL$ = Empty
        End If
    Next i
    bitir = Timer - basla
    MsgBox "İndirme işlemi " & Format(bitir, "00:00:00.00") & " süresinde tamamlanmıştır. ", _
     vbInformation + vbMsgBoxRtlReading, "Www.ExcelVBA.Net"
    i = Empty
End Sub

 

[Haluk]

"For-Next" döngüsü kestirmeden şöyle de düzenlenebilir;

    For i = 2 To son
        If Left(Range("Q" & i).Text, 4) = "http" Then DownloadFile Range("Q" & i).Text, DosyaYolu & Range("E" & i) & ".jpg"
    Next

.

 

[vurkan]

Sayın Askm son verdiğiniz kod tıpkı bir önceki gibi çalıştı. Ancak Sayın Haluk Bey'in önerdiği "For-Next" döngüsü kodların istediğim gibi çalışmasını sağladı. İlgi ve emekleriniz için çok teşekkür ederim. İyi ki varsınız. Saygılar.