• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Web sitesinden bilgi nasıl alınır

  • Konbuyu başlatan Konbuyu başlatan k0081
  • Başlangıç tarihi Başlangıç tarihi
Katılım
17 Haziran 2008
Mesajlar
1,874
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Merhaba arkadaşlar;

bir web sitesinde bilgi nasıl alınır, örnekle açıklayabilirmisiniz ?

Msgbox ile bilgi vermesi yeterlidir.


örnek site : http://www.demirfiyatlari.com/

Bugün Tarihli:

Q8mm Q10mm Q12mm ve Q32 arası

yardımıcı arkadaşa şimdiden Teşekkür ederim.
 
Kod:
Private Sub CommandButton1_Click()
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "http://www.demirfiyatlari.com/"
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("htmlFile")
    HTML.body.innerhtml = objHTTP.responseText

    Set List = HTML.GetElementById("list")
    Set div = List.GetElementsByTagName("DIV")
    baslik = div(0).innertext
   
    Dim sutunlar(0 To 11, 0 To 3)
   
    Set th = List.GetElementsByTagName("TH")
    For i = 0 To 3
        sutunlar(0, i) = th(i).innertext
    Next i

    Set tbody = List.GetElementsByTagName("TBODY")
    Set tr = tbody(0).GetElementsByTagName("Tr")
    For i = 0 To 10
        Set td = tr(i).GetElementsByTagName("TD")
        For ii = 0 To 3
            sutunlar(i + 1, ii) = td(ii).innertext & vbTab
        Next ii
    Next i
   
    Set objHTTP = Nothing
    Set HTML = Nothing
    Set List = Nothing
    Set div = Nothing
    Set th = Nothing
    Set tbody = Nothing
    Set tr = Nothing
    Set td = Nothing

    ListBox1.List = sutunlar
    Label1.Caption = baslik
End Sub

https://yadi.sk/d/ytXVxEZNTsZlgQ
 

Ekli dosyalar

Son düzenleme:
veyselemre;

Hocam kod için teşekkür ederim.

Tabloyu indiremedim. başka bir paylaşım linki verebilirmisiniz ? bir de bu kodlarla ilgili sorum olacak.
 
Kod:
Private Sub CommandButton1_Click()
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "http://www.demirfiyatlari.com/"
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("htmlFile")
    HTML.body.innerhtml = objHTTP.responseText

    Set List = HTML.GetElementById("list")
    Set div = List.GetElementsByTagName("DIV")
    baslik = div(0).innertext
   
    Dim sutunlar(0 To 11, 0 To 3)
   
    Set th = List.GetElementsByTagName("TH")
    For i = 0 To 3
        sutunlar(0, i) = th(i).innertext
    Next i

    Set tbody = List.GetElementsByTagName("TBODY")
    Set tr = tbody(0).GetElementsByTagName("Tr")
    For i = 0 To 10
        Set td = tr(i).GetElementsByTagName("TD")
        For ii = 0 To 3
            sutunlar(i + 1, ii) = td(ii).innertext & vbTab
        Next ii
    Next i
   
    Set objHTTP = Nothing
    Set HTML = Nothing
    Set List = Nothing
    Set div = Nothing
    Set th = Nothing
    Set tbody = Nothing
    Set tr = Nothing
    Set td = Nothing

    ListBox1.List = sutunlar
    Label1.Caption = baslik
End Sub

https://yadi.sk/d/ytXVxEZNTsZlgQ


Hocam kod için teşekkürler. Ama bu şekilde değil. Mesaj olarak alacağız. Ve fiyatı en düşük olanları.
 
Kod:
Private Sub CommandButton1_Click()
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "http://www.demirfiyatlari.com/"
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("htmlFile")
    HTML.body.innerhtml = objHTTP.responseText

    Set List = HTML.GetElementById("list")
    Set div = List.GetElementsByTagName("DIV")
    baslik = div(0).innertext
  
    Dim sutunlar(0 To 11, 0 To 3)
  
    Set th = List.GetElementsByTagName("TH")
    For i = 0 To 3
        sutunlar(0, i) = th(i).innertext
    Next i

    Set tbody = List.GetElementsByTagName("TBODY")
    Set tr = tbody(0).GetElementsByTagName("Tr")
    For i = 0 To 10
        Set td = tr(i).GetElementsByTagName("TD")
        For ii = 0 To 3
            sutunlar(i + 1, ii) = td(ii).innertext & vbTab
        Next ii
    Next i
  
    Set objHTTP = Nothing
    Set HTML = Nothing
    Set List = Nothing
    Set div = Nothing
    Set th = Nothing
    Set tbody = Nothing
    Set tr = Nothing
    Set td = Nothing

    ListBox1.List = sutunlar
    Label1.Caption = baslik
End Sub

https://yadi.sk/d/ytXVxEZNTsZlgQ


Hocam bu çalışmada ; ACCESS DENIED hatası alıyorum şu an...
 
Geri
Üst