Livescore.Im - 7m.cn Sitesinden Anlık Maç Skorlarını Çekme

[size=150][b]Livescore.Im - 7m.cn[/b][/size] sitesinden anlık maç skorlarını çekmek için aşağıda vereceğim kodları kullanabilirsiniz...

[img] [/img]

Gerekli Nesneler
■ UserForm
■ 1 Adet WebBrowser
■ 2 Adet CommandButton

■ Bu kodları kullanabilirsiniz; 

Private Sub CommandButton1_Click()

    ie.Navigate "http://livescore.im/soccer/7mcn"
    CommandButton1.Caption = "Bağlantı Kuruluyor..."
    Do While ie.Busy: DoEvents: Loop
    CommandButton2_Click
    
End Sub

Private Sub CommandButton2_Click()
    Dim i As Integer, a As Integer, c As Integer, j As Integer
    
    'Verilerin olduğu frame'in kaynak adresini buluyoruz..
    adres = ie.Document.getelementsbytagname("IFRAME")(1).src
    'bulduğumuz adrese gidiyoruz
    ie.Navigate adres
    
    Do While Not ie.readyState = 4: DoEvents: CommandButton1.Caption = "Transfer Ediliyor...": Loop
    
    Set s1 = ThisWorkbook.Worksheets("Sheet1")
        s1.AutoFilterMode = False
        s1.Cells.Delete
        
    On Error GoTo bitti
    For i = 0 To 8
        If InStr(1, ie.Document.getelementsbytagname("TABLE")(i).innertext, "DP", vbTextCompare) > 0 Then
            Set docX = ie.Document.getelementsbytagname("TABLE")(i)

    For Each tr In docX.all.tags("TR")
            c = c + 1
            For j = 0 To tr.all.tags("TD").Length - 1
                s1.Cells(c, j + 1) = tr.all.tags("TD").Item(j).innertext
            Next j
    Next tr
        End If
    Next i
bitti:
    
    Application.ScreenUpdating = False
        For a = Range("B65536").End(3).Row To 7 Step -1
            If IsEmpty(Cells(a, 2)) And IsEmpty(Cells(a, 1)) Then
                Rows(a).Delete
            End If
            
            If Len(Cells(a, 1)) > 30 Then
                Rows(a).Delete
            End If
            
            If Cells(a, 2) <> Cells(a + 1, 2) Then
                Cells(a + 1, 2).Resize(, 7).Font.ColorIndex = 3
            End If
        Next a
    Application.ScreenUpdating = True
    
    Range("1:1").Font.Bold = True
    Range("1:1").Font.ColorIndex = 5
    Range("2:4,6:6").Select
    Range("A6").Activate
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Columns.AutoFit
    CommandButton1.Caption = "Transfer Tamamlandı..."
    a = Empty: c = Empty: i = Empty: j = Empty
End Sub

 Hoşça kalın !