Web Sayfasından Resim Alma

A

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
Kolay gelsin.
Bir tablo veya div içerisindeki tüm resimleri orjinal adları ile alma imkanım olur mu. Daha önceden indirilmiş resimleri tekrar indirmeyecek. Örneğinhttp://www.sahibinden.com/ilan/emlak-konut-satilik-sahibinden-ruhsatli-super-villa-232669689/detay
a girecek. Alttaki 10 adet resmi indirecek. Mümkün müdür.
 
A

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
Aşağıdaki kodlar ile sayfadaki tüm resimleri alıyorum.(Murat Beyin 2 programda yaptığı kodları birleştirerek yaptım.) İstediğim tüm sayfa değil de sadece div veya tablo içerisi ile sınırlama nasıl olur.

Sub Evn()
Dim i As Integer
basla = Timer
Call Tüm_Resim_Adreslerini_Al
Const MsgText = "Dosyalar İndirilsin mi ?"
Const MsgHdr = "İnidiriliyor..."
If MsgBox(MsgText, vbYesNo Or vbMsgBoxRtlReading Or vbExclamation, MsgHdr) = vbYes Then
Klasor = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Evn Download"
If CreateObject("Scripting.FileSystemObject").FolderExists(Klasor) = False Then
MkDir (Klasor)
End If
For i = 2 To Range("A65536").End(3).Row
Cells(i, "C").Value = Right(Cells(i, "A"), 3)
URL$ = Cells(i, "A").Value
Dosya$ = Klasor & "\" & Right(URL$, InStr(1, StrReverse(URL$), "/", vbTextCompare) - 1)
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya$) = True Then
'MsgBox Dosya$ & Chr(10) & Chr(10) & "Bu dosya var"
Else
DownloadFile URL$, Dosya$
End If
'CreateObject("Wscript.shell").Run """" & dosya$ & """" - Dosyayı çalıştır...
Next i
End If
bitir = Timer - basla
MsgBox "İndirme işlemi " & Format(bitir, "00:00:00.00") & " sürede tamamlanmıştır. ", _
vbInformation + vbMsgBoxRtlReading, "Www"
i = Empty
End Sub
Sub Tüm_Resim_Adreslerini_Al()
Dim ie As Object, doc As Object, i As Integer
Set ie = CreateObject("InternetExplorer.Application")
Set doc = CreateObject("MSXML2.XMLHTTP")
ie.navigate Sayfa2.Range("a1").Value
'ie.navigate Sayfa1.TextBox1.Text
'ie.navigate "http://www.dmi.gov.tr/tahmin/il-ve-ilceler.aspx?m=istanbul"
Do While ie.ReadyState <> 4: DoEvents: Loop
Set doc = ie.document: a = 1
For i = 1 To doc.images.Length
If doc.images(i - 1).nodeName = "IMG" And _
doc.images(i - 1).fileSize > 0 Then
Cells(a, "A") = doc.images(i - 1).href
a = a + 1
End If
Next i: ie.Quit
Set doc = Nothing: Set ie = Nothing: 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
If XMLHTTP.statustext = "OK" Then
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
Else
MsgBox "Bağlantı sağlanamadı", vbInformation, "Hata !"
End If
Set XMLHTTP = Nothing
End Function
 
A

alicimri

Katılım
12 Aralık 2015
Mesajlar
1,207
Excel Vers. ve Dili
Türkçe Ofis 2007
Sayın askm
Biraz uğraştım sorunuz üzerinde ama çözümlerden hepsi sorunlu.
Resimlerini almak istediğin siteyi "Internet explorer" ile aç.
Dosya>Faklı Kaydet>Web Sayfası tam(*.htm*.htm)
seçeneği ile dosyayı indir. İnen .htm dosyası ile birlikte inecek klasörde resimler mevcut
 
A

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
Yukarıdaki kodlar ile sayfadaki resimleri indiriyorum. Benim istediğim sınırlama.
 
A

alicimri

Katılım
12 Aralık 2015
Mesajlar
1,207
Excel Vers. ve Dili
Türkçe Ofis 2007
Sayın askm
Aşağıdaki kodlar söz konusu sitedeki büyük resimleri D sürücüsündeki resim klasörüne indiriyor. Ancak kısıtlamalar bu sitedeki duruma göre ayarlanmıştır. büyük resimlerin adresleri 61 karakter, küçük resimler ise 66 karakter. Sayın murat osma'nın DownloadFile fonksiyonunu kullandım.
Kod: 
Sub Macro1()
 Set ie = CreateObject("InternetExplorer.Application")
 ie.Navigate "http://www.sahibinden.com/ilan/emlak-konut-satilik-sahibinden-ruhsatli-super-villa-232669689/detay"
 ie.Visible = True
 Do While ie.ReadyState <> 4
 Loop
 iL = ie.Document.all.length
 For i = 1 To iL
 On Error Resume Next
 strTmp = ie.Document.all(i).getAttribute("src")
If Right(strTmp, 4) = ".jpg" And Len(strTmp) = 61 Then
DownloadFile strTmp, "D:\resim\" & Right(strTmp, 15)
End If
Next
ie.Quit
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
    If XMLHTTP.StatusText = "OK" Then
    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
    Else
    MsgBox "Bağlantı sağlanamadı", vbInformation, "Hata !"
    End If
    Set XMLHTTP = Nothing
End Function
 
A

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
Teşekkür ederim kodunuz için. resim klasörü yoksa klasör oluşturması için kodu aşağıdaki şekilde değiştirdim. Ama hata veriyor.
If CreateObject("Scripting.FileSystemObject").FolderE xists(Klasor) = False Then kısmı kırmızı. Sanırım bura için bir referans gerekli ama hangi referans. İşyerinde benim verdiğim kodlar çalışıyordu. Evde çalışmıyor. ikisinde de Office 2010 var. İŞyerindeki 64 bit evdeki 32 bit.


Sub Macro1()
Set ie = CreateObject("InternetExplorer.Application")
ie.navigate "http://www.sahibinden.com/ilan/emlak-konut-satilik-sahibinden-ruhsatli-super-villa-232669689/detay"
ie.Visible = True
Do While ie.ReadyState <> 4
Loop
iL = ie.document.all.Length
For i = 1 To iL
On Error Resume Next

If MsgBox(MsgText, vbYesNo Or vbMsgBoxRtlReading Or vbExclamation, MsgHdr) = vbYes Then
Klasor = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Evn Download"
If CreateObject("Scripting.FileSystemObject").FolderE xists(Klasor) = False Then
MkDir (Klasor)
End If
End If

strTmp = ie.document.all(i).getAttribute("src")
If Right(strTmp, 4) = ".jpg" And Len(strTmp) = 61 Then
'DownloadFile strTmp, "D:\resim\" & Right(strTmp, 15)
DownloadFile strTmp, Klasör & Right(strTmp, 15)
End If
Next
ie.Quit
End Sub
 
A

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
Aşağıdaki şekilde klasör yoksa da oluşturuyor.

Sub Macro1()
Set ie = CreateObject("InternetExplorer.Application")
ie.navigate "http://www.sahibinden.com/ilan/emlak-konut-satilik-sahibinden-ruhsatli-super-villa-232669689/detay"
ie.Visible = True

'If MsgBox(MsgText, vbYesNo Or vbMsgBoxRtlReading Or vbExclamation, MsgHdr) = vbYes Then
On Error Resume Next
Klasor = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Evn Download"
If Dir(Klasor) = "" Then
MkDir Klasor
Else
End If
'End If


Do While ie.ReadyState <> 4
Loop
iL = ie.document.all.Length
For i = 1 To iL
On Error Resume Next

strTmp = ie.document.all(i).getAttribute("src")
If Right(strTmp, 4) = ".jpg" And Len(strTmp) = 61 Then
'DownloadFile strTmp, "D:\resim\" & Right(strTmp, 15)
DownloadFile strTmp, Klasor & "\" & Right(strTmp, 15)
End If

Next
ie.Quit
End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,788
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kod sayfadaki 480x360 ebadındaki resimleri masa üstündeki resim klasörüne kapyalıyor.

Kod: 
Sub Macro1()
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "http://www.sahibinden.com/ilan/emlak-konut-satilik-sahibinden-ruhsatli-super-villa-232669689/detay"
'IE.Navigate "http://image5.sahibinden.com/photos/89/52/36/257895236itl.jpg"
ie.Visible = True
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
Klasor = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\resim"

If CreateObject("Scripting.FileSystemObject").FolderExists(Klasor) = False Then
MkDir Klasor
End If

On Error Resume Next

Set objInputs = ie.Document.getElementsByTagName("*")
For Each nesne In objInputs
deg3 = nesne.ID
If Right(nesne.src, 4) = ".jpg" Then
'MsgBox nesne.src & Chr(10) & nesne.Width & Chr(10) & nesne.Height
If nesne.Width = "480" And nesne.Height = "360" Then
deg1 = Split(nesne.src, "/")
If UBound(deg1) > 0 Then
veri = deg1(UBound(deg1))
If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & "\" & veri) = True Then
Else
DownloadFile nesne.src, Klasor & "\" & veri
End If
End If
End If

End If
Next

ie.Quit
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
    If XMLHTTP.StatusText = "OK" Then
    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
    Else
    MsgBox "Bağlantı sağlanamadı", vbInformation, "Hata !"
    End If
    Set XMLHTTP = Nothing
End Function
 
Zeki Gürsoy

Zeki Gürsoy

Uzman
Uzman
Katılım
31 Aralık 2005
Mesajlar
4,334
Excel Vers. ve Dili
Office 2019 (64 bit) - Türkçe
Bu da benden...

Kod: 
Sub test()
    Dim IE As Object, divs As Object, images As Object, desk As String, img As Object
    
    Set IE = CreateObject("InternetExplorer.Application")
    
    IE.navigate _
    "http://www.sahibinden.com/ilan/emlak-konut-satilik-sahibinden-ruhsatli-super-villa-232669689/detay"
    
    Do Until IE.readystate = 4: DoEvents: Loop
    Do While IE.busy: DoEvents: Loop
    
    Set divs = IE.document.getelementsbyclassname("classifiedDetailMainPhoto")
    
    Set images = divs(0).getelementsbytagname("img")
    
    desk = CreateObject("wscript.shell").specialfolders("desktop") & "\Evn Download\"
    
    If Dir(desk, vbDirectory) = "" Then MkDir desk
    
    For Each img In images
        DoEvents
        Call DownloadPicture(img.src, desk)
    Next
    
    IE.Quit
    Set images = Nothing
    Set divs = Nothing
    Set IE = Nothing
    
End Sub

Private Sub DownloadPicture(ByVal url As String, ByVal klasor As String)
    Dim xmlHTTP As Object, byt() As Byte, p As String, f As Integer
    
    p = IIf(Right(klasor, 1) = "\", klasor, klasor & "\")
    
    Set xmlHTTP = CreateObject("msxml2.xmlhttp")
    
    xmlHTTP.Open "get", url, False
    xmlHTTP.send
    
    byt = xmlHTTP.responsebody
    
    f = UBound(Split(url, "/"))
    
    Reset
    
    Open p & Split(url, "/")(f) & ".jpg" For Binary As #1
        Put #1, , byt
    Close #1
    
    xmlHTTP.abort
    Set xmlHTTP = Nothing
End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,788
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu uygulamada farklı bu kod tek başına uygulanıyor

Kod: 
Sub Macro15()

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
uzanti = "jpg"

Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "http://www.sahibinden.com/ilan/emlak-konut-satilik-sahibinden-ruhsatli-super-villa-232669689/detay"
IE.Visible = True
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
klasor = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\resim"

If fL.folderexists(klasor) = False Then
MkDir klasor
End If

Set objInputs = IE.Document.getelementsbytagname("image")
For Each nesne In objInputs
If Val(Len(nesne.src)) > 0 Then

If fL.GetExtensionName(nesne.src) = uzanti Then
If nesne.Width = "480" And nesne.Height = "360" Then
deg1 = Split(nesne.src, "/")
If UBound(deg1) > 0 Then
veri = deg1(UBound(deg1))
If fL.FileExists(klasor & "\" & veri) = False Then
Dim xmlHTTP, ADOStream
Set xmlHTTP = CreateObject("Microsoft.XMLHTTP")
xmlHTTP.Open "GET", nesne.src$, "False"
xmlHTTP.send

Set ADOStream = CreateObject("ADODB.Stream")
ADOStream.Type = 1: ADOStream.Open
ADOStream.Write xmlHTTP.responsebody
ADOStream.SaveToFile (klasor & "\" & veri), 2
ADOStream.Close: Set ADOStream = Nothing

End If
End If
End If
End If
End If
Next

IE.Quit
MsgBox "işlem tamam"
End Sub
 
yasin85

yasin85

Altın Üye
Katılım
29 Haziran 2011
Mesajlar
264
Excel Vers. ve Dili
2019, Türkçe
Altın Üyelik Bitiş Tarihi
25-08-2026
Merhaba Değerli Arkadaşlar,

Kullanıcı ve Şifreli giriş yaptığım "B2B" kullandığım tedarikcimin her ürün sayfalarında resimleri mevcut bu resimleri bilgisayarıma indirmek istiyorum.

Resim direkt indirirsek sayfa içinde yazan "Üretici Kodu" alanında yazan kodu resim ismi yapmalıyız ki resimleri sonrasında ayrıştıra bileyim.
"Üretici Kodu" alanında yazan ürün kodu bilgileri
xpath :
//*[@id="cphMainContent_lblProductManufacturerCode"]
html kodu :
<span id="cphMainContent_lblProductManufacturerCode">01.101.01</span>

yada

Resimi direkt indirmek olmuyorsa resim link adreslerini "A" sutununda bulunan ürün linklerinin yanında "B" sutununa resim linklerini yazmasıda işimi görür linklere istinaden ayrıştıra bilirim resim linklerinden indire bilirim.

Önemli Not

B2B programı sadece "Chrome" ile açılıyor sisteme giriş yapıyoruz fakat "InternetExplorer" açılmıyor kullanıcı girişi yapamıyoruz.

selenium veya google sheets ve python programından olan tüm kodları test ede bilirim.

yapay zeka deneyerek kodlar oluşturdu fakat çözüme ulaşamadım.

sayfa kod bilgilerini yazdım bu bilgilere istinaden yardımcı ola bilirmisiniz.

xpath :
//*[@id="lightSlider"]/li/a/img

html kodu :
<li data-thumb="http://b2b.-----.com.tr/files/product/b562df7a-ce8f-4ae0-95d6-3fc2db4cb544.jpg" class="lslide active" style="width: 340px; margin-right: 0px;">
<a href="http://b2b.-----.com.tr/files/product/b562df7a-ce8f-4ae0-95d6-3fc2db4cb544.jpg" data-lightbox="p0" data-title="">
<img alt="" src="http://b2b.-----com.tr/files/product/b562df7a-ce8f-4ae0-95d6-3fc2db4cb544.jpg">
</a>
</li>
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst