Otomatik Plaka Sorgulama

[cipro3535]

Merhabalar ,

Benim bir proje gereği elimde bulunan plakaları http://www.turkiye.gov.tr/portal/dt?channel=hizmet&hizmet.hizmetKodu=759 adresinden otomatik olarak sorgulatıp , çıkan sonuçları excele aktaracak bir makroya ihitiyacım var.Bunu için sitemizi , inceleyip bir çalışma yaptım.Fakat konuyla ilgili bilgim olmadığından pek başarılı olamadım.Siteye girip plakayı sorguluyor , sonuçları listeliyor. Ancak buradan sonra takılıyor.Sonuçları sayfaya aktarmıyor.Tabi ki 2.plakaya da geçmiyor.Buradan sonrası için aşağıdaki kodları düzeltmek için yardımınızı rica ediyorum.(Sayfa kaynak kodu ektedir.)

Teşekkürler...


Sub Sorgula()
Dim Son As Integer, Say As Integer
Son = ActiveSheet.Range("A65536").End(xlUp).Row
Set Web = CreateObject("InternetExplorer.application")
For Say = 2 To Son
Denetle ActiveSheet.Range("A" & Say).Value, Say
Next
Set Web = Nothing
MsgBox "İşlem tamam.", vbInformation, "Sonuç"
End Sub

Sub Denetle(PLAKA, Say)
On Error GoTo Hata
Web.Navigate "https://www.turkiye.gov.tr/portal/dt?channel=hizmet&hizmet.hizmetKodu=759"
Do While Web.Busy: DoEvents: Loop
Do While Web.ReadyState <> 4: DoEvents: Loop
Web.Document.getElementById("f1").Value = PLAKA
Web.Document.getElementById("submit").Click

Do While Web.Busy: DoEvents: Loop
Do While Web.ReadyState <> 4: DoEvents: Loop

With ActiveSheet
.Range("B" & Say).Value = Web.Document.all.tags("Marka").Item(2).Rows(11).Cells(1).innerText
.Range("C" & Say).Value = Web.Document.all.tags("Model").Item(2).Rows(22).Cells(1).innerText
.Range("D" & Say).Value = Web.Document.all.tags("Sahiplik Belge Tarihi").Item(2).Rows(33).Cells(1).innerText
.Range("E" & Say).Value = Web.Document.all.tags("Cinsi").Item(2).Rows(44).Cells(1).innerText
End With
Exit Sub
Hata:
Range("A1") = Err.Number
If Err.Number = 91 Then
Err.Clear
Do While Web.Busy: DoEvents: Loop
Do While Web.ReadyState <> 4: DoEvents: Loop
If InStr(Web.Document.all.tags("table").Item(2).innerText, "SORGULADIĞINIZ KİŞİNİN") > 0 Then Exit Sub
Resume
Else: Exit Sub
End If
End Sub