Excel'de Siteden resim URL'si çekmek

alex10mk · 25 Aralık 2017

Merhaba arkadaşlar,

Başlıkta da belirttiğim konuyu kısaca özetlemek gerekirse;

A1 sutününda yer alan bir site urlsin, site içerisinde yer alan resmin URL'sini A2 hücresine otomatik olarak yazdırma şansımız var mıdır?

Yardımlarınızı bekliyorum, şimdiden teşekkürler.

askm · 25 Aralık 2017

Örnek dosya eklerseniz bakalım.

alex10mk · 25 Aralık 2017

Tabiki paylaşıyorum hemen ancak dosya yüklemeyi bilmediğim için link şeklinde atıyorum.

https://mega.nz/#!xEIR1SpD!To8aO8wCQiQMY21u2fJG2f9Oqa6-mWVi46YiUYhqb0I

eğer bu şekilde paylaşmam uygun değilse, dosya yükleme yöntemini söylerseniz hemen ekleyebilirim

Merhum İdris SERDAR · 25 Aralık 2017

.

İngilizceleri:

Insert > Pictures > File name: karşısındaki boşluğa resmin web adresini yapıştırdıktan sonra Insert'e basın.

.

alex10mk · 25 Aralık 2017

İdris SERDAR' Alıntı:
.

İngilizceleri:

Insert > Pictures > File name: karşısındaki boşluğa resmin web adresini yapıştırdıktan sonra Insert'e basın.

.

İdris bey cevabınız için teşekkür ederim ancak yapamadım.

Aslında benim yapmak istediğim örnekte vermiş olduğum gibi birçok link mevcut.
Her linkten o ürüne ait resmin URL şeklinde diğer hücreye çekmek. Bunu otomatik şekilde yapabilir miyim?

alex10mk · 25 Aralık 2017

Örneğin A1 hücresinde bu yazıcak https://tr.gearbest.com/sports-fitness-headphones/pp_356162.html?wid=90?lkid=12279416

buna karşılık B1 hücresinde https://gloimg.gbtcdn.com/gb/pdm-product-pic/Electronic/2016/04/22/goods-img/1511579409491739195.jpg bunun olmasını istiyorum. URL şeklinde

Asri · 26 Aralık 2017

Aşağıdaki şekilde deneyiniz.

Sayın Haluk'un kod revizesi yapıldı.

Kod:

Sub resim_url_getir2()
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   For j = 1 To sonsatir
     Cells(j, "B").Value = parsehtml_Revize(Cells(j, "A").Value)
   Next j
End Sub
'
Function parsehtml_Revize(kucukresimurl) As String
    Dim http As Object, html As Object, i As Integer

    Set html = CreateObject("HTMLFILE")
    Set http = CreateObject("MSXML2.XMLHTTP")

    http.Open "GET", kucukresimurl, False
    http.send

    html.body.innerHTML = http.responseText

    Set objCollection = html.getElementsByTagName("input")
    i = 0
    Do While i < objCollection.Length
      If objCollection(i).ID = "js_hidden-goodsImg" Then
         parsehtml_Revize = objCollection(i).Value
         Exit Function
      End If
      i = i + 1
    Loop
    parsehtml_Revize = ""
End Function

askm · 26 Aralık 2017

Alternatif

Kod:

Sub ASKM_webpage1()
On Error Resume Next
Dim son As Long
son = Range("A" & Rows.Count).End(xlUp).Row

    Dim internet As Object
    Dim internetdata As Object
    Dim div_result As Object
    Dim header_links As Object
    Dim link As Object
    Dim URL As String

    Set internet = CreateObject("InternetExplorer.Application")
    internet.Visible = False

Range("b1:b1000").ClearContents
For i = 1 To son
    URL = Cells(i, 1)
    internet.Navigate URL
Application.StatusBar = URL & " Yükleniyor"
    Do Until internet.ReadyState >= 4
        DoEvents
    Loop

    Set internetdata = internet.Document
    Set div_result = internetdata.getelementbyid("js_n_bigImg")


    Set header_links = div_result.getElementsByTagName("img")

For Each link In header_links
    Cells(i, 2).Value = link.src
    Exit For
Next
Next i

internet.Quit
Application.StatusBar = ""
Set internet = Nothing
Set header_links = Nothing
Set internetdata = Nothing
Set div_result = Nothing
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

Haluk · 26 Aralık 2017

asri' Alıntı:
VBA /tools/ reference de "Microsoft HTML Object Library" seçili olmalı.

Sayın asri;

Müsaade edersiniz ufak ama, yararlı olacak bir öneride bulunabilir miyim?

Kodlarınızdaki parsehtml isimli fonksiyonda html değişkenini Early Binding, http değişkenini Late Binding olarak deklare etmişiniz. Bu nedenle de; mesajınızın başında, yukarıda yaptığım alıntıda belirttiğim uyarınızı yapmışsınız.

Bence; html değişkenini de Late Binding olarak deklare edip, aşağıdaki gibi bir kod kullanırsanız, kullanıcıların referans eklemesine gerek kalmaz.

Bildiğiniz gibi; değişkenlerin Late Binding olarak deklare edilmesi durumunda, kodun çalıştırılmasından sonra (Run Time) bilgisayarda o nesneye ait geçerli referans projeye eklenmiş gibi kodlar derlenecektir.

Biraz kafanızı şişirmiş olabilirim, uzun lafın kısası;

Kod:

Dim html As Object

Set html = CreateObject("HTMLFILE")

Selamlar,

.

askm · 26 Aralık 2017

Sayın Haluk Bey açıklamanız biraz uzun olduğu için pek anlaşılmıyor. Kodların tamamında revize yapıp eklerseniz daha açık olur.

Haluk · 26 Aralık 2017

Sayın askm;

Açıklamalarım çok da uzun değildi, belki biraz işin tekniğine kaçtığı için size sıkıcı gelmiş olabilir.

Aslında, mesajlarımın altındaki imzamda belirtildiği gibi; "Kod anlatılmaz, yazılır" benim felsefemdir. Kırk yılın başında bir açıklama yapayım dedim, ama anlaşılamadım demek ... :biggrin:

Neyse, sizi de kırmayalım..... oltayı kenara bırakalım ve ayıklanmış, pişmiş balığı sofraya servis edelim;

"Microsoft HTML Object Library" referansı eklemeden yapmak için gerekli kod:

Kod:

Sub resim_url_getir2()
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   For j = 1 To sonsatir
     Cells(j, "B").Value = parsehtml_Revize(Cells(j, "A").Value)
   Next j
End Sub
'
Function parsehtml_Revize(kucukresimurl) As String
    Dim http As Object, html As Object, i As Integer

    Set html = CreateObject("HTMLFILE")
    Set http = CreateObject("MSXML2.XMLHTTP")
    
    http.Open "GET", kucukresimurl, False
    http.send
    
    html.body.innerHTML = http.responseText
    
    Set objCollection = html.getElementsByTagName("input")
    i = 0
    Do While i < objCollection.Length
      If objCollection(i).ID = "js_hidden-goodsImg" Then
         parsehtml_Revize = objCollection(i).Value
         Exit Function
      End If
      i = i + 1
    Loop
    parsehtml_Revize = ""
    
    Set html = Nothing
    Set http = Nothing
End Function

.

askm · 26 Aralık 2017

İlginiz için teşekkür ederim. Dikkat ederseniz ben de pek hazır balık isteyen biri değilim ama gerçekten de ben anlamamıştım. En azından bir kere balığı pişmiş görmek bazen iyi oluyor.

Asri · 26 Aralık 2017

Haluk' Alıntı:
Sayın asri;

Müsaade edersiniz ufak ama, yararlı olacak bir öneride bulunabilir miyim?

Kodlarınızdaki parsehtml isimli fonksiyonda html değişkenini Early Binding, http değişkenini Late Binding olarak deklare etmişiniz. Bu nedenle de; mesajınızın başında, yukarıda yaptığım alıntıda belirttiğim uyarınızı yapmışsınız.

Bence; html değişkenini de Late Binding olarak deklare edip, aşağıdaki gibi bir kod kullanırsanız, kullanıcıların referans eklemesine gerek kalmaz.

Bildiğiniz gibi; değişkenlerin Late Binding olarak deklare edilmesi durumunda, kodun çalıştırılmasından sonra (Run Time) bilgisayarda o nesneye ait geçerli referans projeye eklenmiş gibi kodlar derlenecektir.

Biraz kafanızı şişirmiş olabilirim, uzun lafın kısası;

Kod:

Dim html As Object Set html = CreateObject("HTMLFILE")

Selamlar,

.

Açıklama ve öneri için teşekkür ederim.
Kod gönderdiğiniz şekilde güncellendi ve arşive eklendi

Haluk · 26 Aralık 2017

Sayın askm; sadece latife etmiştim. Lütfen gücenmeyin...

Sayın Asri Bey; rica ederim, kolay gelsin.

.

alex10mk · 26 Aralık 2017

asri' Alıntı:

Aşağıdaki şekilde deneyiniz.

Sayın Haluk'un kod revizesi yapıldı.

Kod:

Sub resim_url_getir2()
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   For j = 1 To sonsatir
     Cells(j, "B").Value = parsehtml_Revize(Cells(j, "A").Value)
   Next j
End Sub
'
Function parsehtml_Revize(kucukresimurl) As String
    Dim http As Object, html As Object, i As Integer

    Set html = CreateObject("HTMLFILE")
    Set http = CreateObject("MSXML2.XMLHTTP")

    http.Open "GET", kucukresimurl, False
    http.send

    html.body.innerHTML = http.responseText

    Set objCollection = html.getElementsByTagName("input")
    i = 0
    Do While i < objCollection.Length
      If objCollection(i).ID = "js_hidden-goodsImg" Then
         parsehtml_Revize = objCollection(i).Value
         Exit Function
      End If
      i = i + 1
    Loop
    parsehtml_Revize = ""
End Function

asri bey; öncelikle teşekkürleri iletiyorum.

vermiş olduğunuz kod askm beyin koduna göre daha seri çalışıyor ancak 95 adetten sonra aşağıdaki hataları alıyorum.

askm' Alıntı:

Alternatif

Kod:

Sub ASKM_webpage1()
On Error Resume Next
Dim son As Long
son = Range("A" & Rows.Count).End(xlUp).Row

    Dim internet As Object
    Dim internetdata As Object
    Dim div_result As Object
    Dim header_links As Object
    Dim link As Object
    Dim URL As String

    Set internet = CreateObject("InternetExplorer.Application")
    internet.Visible = False

Range("b1:b1000").ClearContents
For i = 1 To son
    URL = Cells(i, 1)
    internet.Navigate URL
Application.StatusBar = URL & " Yükleniyor"
    Do Until internet.ReadyState >= 4
        DoEvents
    Loop

    Set internetdata = internet.Document
    Set div_result = internetdata.getelementbyid("js_n_bigImg")


    Set header_links = div_result.getElementsByTagName("img")

For Each link In header_links
    Cells(i, 2).Value = link.src
    Exit For
Next
Next i

internet.Quit
Application.StatusBar = ""
Set internet = Nothing
Set header_links = Nothing
Set internetdata = Nothing
Set div_result = Nothing
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

askm bey,
kodunuz asri beyin koduna göre biraz daha yavaş ancak hiç bir hata almadım. teşekkür ederim.

Haluk · 26 Aralık 2017

alex10mk;

Aldığınız hata mesajının nedeni gayet açık.....

İstek yolladığınız sunucu DoS saldırısı tehdine karşılık erişimizi engelliyor. Biraz daha devam ederseniz, IP adresinizi ban'larlar ve siteye hiç ulaşamazsınız.

Bu tür anlık bilgi amacıyla sunuculara gönderilen aşırı yoğun istekler DoS saldırısı olarak kabul edilir. Bunu engellemek için; makul aralıklarla istek göndermeniz gerekir ..... Bazı sunucular, dakikada 1'den fazla isteği DoS saldırısı olarak kabul eder.

askm'nin kodundaki bekletme kodu bu işi bir yerde çözüyor. Asri Bey'in kodu ise daha hızlı çalışır ancak; bazı ilave kontroller gerektiriyor aslında. Bunlar da ilave edilirse, daha iyi performans gösterecektir.

.

alex10mk · 26 Aralık 2017

Haluk' Alıntı:
alex10mk;

Aldığınız hata mesajının nedeni gayet açık.....

İstek yolladığınız sunucu DoS saldırısı tehdine karşılık erişimizi engelliyor. Biraz daha devam ederseniz, IP adresinizi ban'larlar ve siteye hiç ulaşamazsınız.

Bu tür anlık bilgi amacıyla sunuculara gönderilen aşırı yoğun istekler DoS saldırısı olarak kabul edilir. Bunu engellemek için; makul aralıklarla istek göndermeniz gerekir ..... Bazı sunucular, dakikada 1'den fazla isteği DoS saldırısı olarak kabul eder.

askm'nin kodundaki bekletme kodu bu işi bir yerde çözüyor. Asri Bey'in kodu ise daha hızlı çalışır ancak; bazı ilave kontroller gerektiriyor aslında. Bunlar da ilave edilirse, daha iyi performans gösterecektir.

.

İyi akşamlar Haluk bey, cevabınız için teşekkür ederim. Ne gibi düzenlemeler yapmak lazım yardımcı olabilir misiniz

yasin85 · 8 Ağustos 2021

Merhabalar,

İhtiyacım olan konuyu formda buldum fakat dosya'ya uygulayamadım bu konuda yardımcı ola bilirmisiniz.

Örnek Dosya Ektedir.
https://s5.dosya.tc/server4/yhk5a1/Excel_de_Siteden_resim_URL_si_cekmek.xlsm.html

veyselemre · 8 Ağustos 2021

Kod:

Sub selenium_urlAl()
'Selenium Web Driver kurulu olmalı
'Referanslardan Selenium Type Library seçili olmalı.

    Set driver = New ChromeDriver
    Set By = New By

    With driver

        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            .Get Cells(i, 1).Value

            While .ExecuteScript("return document.readyState") <> "complete"
                .Wait (5000)
            Wend

            If .FindElements(By.ID("product-product")).Count > 0 Then
                Set t = .FindElementByCss("#content > div.row > div.col-sm-8 > ul.thumbnails")
                Set a = t.FindElementsByCss(".thumbnail")
                For ii = 1 To a.Count
                    Cells(i, ii + 1).Value = a(ii).Attribute("href")
                Next ii
            Else
                Cells(i, 2).Value = "Ürün Bulunamadı."
            End If

        Next i

    End With

End Sub

Haluk · 8 Ağustos 2021

Alternatif;

C++:

Sub Test()
'   Haluk - 08/08/2021
'   sa4truss@gmail.com
'   https://excelhaluk.blogspot.com/

    Dim HTTP As Object, HTML As Object, NoA As Integer, iRow As Integer, i As Integer, j As Integer
    Dim myURL As String
    
    Range("B2:G" & Rows.Count) = ""
    
    Set HTML = CreateObject("HTMLFILE")
    Set HTTP = CreateObject("MSXML2.XMLHTTP")
    
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    
    For iRow = 2 To NoA
        myURL = Range("A" & iRow).Text
        
        HTTP.Open "GET", myURL, False
        HTTP.send
        
        HTML.body.innerHTML = HTTP.responseText
        Set objCollection = HTML.getElementsByTagName("li")
        
        i = 0
        j = 1
        Do While i < objCollection.Length
            If objCollection(i).classname = "image-additional" Then
                Set objImgs = objCollection(i).getElementsByTagName("a")
                j = j + 1
                Cells(iRow, j) = objImgs(0).href
            End If
            i = i + 1
        Loop
    Next
    
    Set objImgs = Nothing
    Set HTML = Nothing
    Set HTTP = Nothing
End Sub

.

Excel'de Siteden resim URL'si çekmek

alex10mk

askm

Destek Ekibi

alex10mk

Merhum İdris SERDAR

Moderatör

alex10mk

alex10mk

Asri

askm

Destek Ekibi

Haluk

Özel Üye

askm

Destek Ekibi

Haluk

Özel Üye

askm

Destek Ekibi

Asri

Haluk

Özel Üye

alex10mk

Haluk

Özel Üye

alex10mk

yasin85

Ekli dosyalar

veyselemre

Özel Üye

Haluk

Özel Üye