Parsel Sorgulama Excele Aktarma

[SAGULNET]

Merhaba sayın arkadaşlar;
Parselin tkgm'den sorgulanması ve excele aktarımı ile ilgili daha önceden bir konu vardı fakat bu konudaki kodların bazılarını tkgm değiştirmiş.

Şimdi bir kod yardımı ile
https://parselsorgu.tkgm.gov.tr/ sitesine gireceğim ve İdari Sorgu Coğrafi Sorgu dan coğrafi sorguyu seçecek, buradaki enleme ve boylama A1 VE A2 hücresindeki değerleri yazacak.

Yardım eden arkadaşlara çok teşekkürler.


Eski kodları;

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Sub verial()
Dim URL As String
Dim ie As Object

URL = "https://parselsorgu.tkgm.gov.tr/"
Set ie = CreateObject("InternetExplorer.Application")

With ie
.Navigate URL
.Visible = 1
ShowWindow ie.hwnd, 3

Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
ie.document.all("cphMaster_rblSorguTip_1").Checked = True
ie.document.all("cphMaster_rblSorguTip_1").Click
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop

Application.Wait (Now + TimeValue("00:00:01"))

On Error Resume Next

sat = 1

Set objInputs = ie.document.getElementsByTagName("input")
For Each nesne In objInputs

If nesne.ID Like "*" & "cphMaster" & "*" = True Then
If sat = 3 Then
ie.document.all(nesne.ID).Value = Replace(Cells(1, "A").Value, ".", ",")

End If

If sat = 4 Then
ie.document.all(nesne.ID).Value = Replace(Cells(2, "A").Value, ".", ",")

End If
sat = sat + 1
'nesne.Click
End If
Next

Application.Wait (Now + TimeValue("00:00:01"))
ie.document.all("ctl00$cphMaster$btnSorgu").Click

'ie.Quit: Set ie = Nothing
End With

End Sub

il ilçe ada parsel ile sorgu;

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Sub aaaverial10()
Dim URL As String
Dim ie As Object

yeni_dosya_adı = ActiveWorkbook.Name

Range("c2:k2").ClearContents


ReDim veri(13)
ReDim yer(13)

yer(1) = "cphMaster_rblSorguTip"
yer(2) = "cphMaster_rblSorguTip_0"
yer(3) = "cphMaster_rblSorguTip_1"
yer(4) = "cphMaster_tblIdariSorguAlan"
yer(5) = "cphMaster_IlLabelYatay"
yer(6) = "cphMaster_IlceLabelYatay"
yer(7) = "cphMaster_MahalleLabelYatay"
yer(8) = "cphMaster_AdaLabelYatay"
yer(9) = "cphMaster_ParselLabelYatay"
yer(10) = "cphMaster_btnSorgu"
yer(11) = "cphMaster_tblMesaj"
yer(12) = "cphMaster_lMesaj"
yer(13) = "cphMaster_map"


URL = "https://parselsorgu.tkgm.gov.tr/"
Set ie = CreateObject("InternetExplorer.Application")

With ie
.Navigate URL
.Visible = 1
ShowWindow ie.hwnd, 6


Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop


On Error Resume Next

Set objInputs = ie.document.getElementsByTagName("*")
sat2 = 0
For Each nesne In objInputs

If Val(Len(nesne.ID)) > 0 Then
deg3 = nesne.ID
If deg3 Like "*" & "cphMaster" & "*" = True Then

deg1 = 0
For m = 1 To 13

If Trim(nesne.ID) = yer(m) Then
deg1 = 1
Exit For
End If
Next

If deg1 = 0 Then
'MsgBox nesne.ID
sat2 = sat2 + 1
veri(sat2) = nesne.ID 'Trim(Replace(nesne.ID, "_", " "))
End If
End If
End If

Next nesne

If sat2 > 0 Then
For t = 1 To sat2
deg3 = veri(t)

If deg3 Like "*" & "cphMaster" & "*" = True Then


If t = 1 Then
hucre = Trim(Cells(1, "b").Text)
ElseIf t = 2 Then
hucre = Trim(Cells(2, "b").Text)
ElseIf t = 3 Then
hucre = Trim(Cells(3, "b").Text)
ElseIf t = 4 Then
hucre = Trim(Cells(4, "b").Text)
ElseIf t = 5 Then
hucre = Trim(Cells(5, "b").Text)
End If

For r = 1 To Val(ie.document.all(deg3).Length)

If hucre = Trim(ie.document.all(deg3)(r).Text) Then
son5 = r
'MsgBox hucre & Chr(10) & Trim(ie.document.all(deg3)(r).Text)
ie.document.all(deg3).selectedIndex = son5
Exit For
End If
Next r


ie.document.all(deg3).OnChange
Application.Wait (Now + TimeValue("00:00:01"))
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop

End If
Next t

Application.Wait (Now + TimeValue("00:00:01"))
ie.document.all("cphMaster_btnSorgu").Click

Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop

Application.Wait (Now + TimeValue("00:00:01"))

Set t = ie.document.getElementsByTagName("table").Item(5)

For j = 0 To 8 't.Cells.Length - 1
Cells(2, j + 3) = t.Rows(1).Cells(j).innerText
Next


End If
'ie.Quit: Set ie = Nothing
End With

Windows(yeni_dosya_adı).Activate

MsgBox "işlem tamam"
End Sub

Önceki geçersiz konu:
http://www.excel.web.tr/f48/parsel-sorgusu-icin-onemli-bir-konu-t151114.html