WEB KAYNAĞINDAN VERİ ÇEKMEK

[hgenc545]

Değerli üstatlar
Aşağıdaki kodun eksik noktalarını tamamlar mısınız...



Sub VeriCek()
Dim XMLHTTP As Object
Dim html As Object
Dim i As Integer
Dim str As String

Set XMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
XMLHTTP.Open "GET", "https://www.mgm.gov.tr/?il=ankara", False
XMLHTTP.send
Set html = CreateObject("htmlfile")
html.body.innerHTML = XMLHTTP.responseText

' Veri çekmek istediğiniz elementin yordamını kullanarak veriyi çekin
str = html.getElementById("element_id").innerText

' Veriyi seçtiğiniz hücreye yerleştirin
ActiveCell.Value = str
End Sub

 

[Haluk]

Sub Test()
    Dim URL As String
    Dim IE As Object
    
    URL = "https://www.mgm.gov.tr/?il=ankara"
    Set IE = CreateObject("InternetExplorer.Application")
    
    IE.Visible = False
    IE.navigate URL
    
    Do Until IE.readyState = 4
    Loop
    
    RetVal1 = IE.document.getElementsByTagName("ziko")(0).innerText
    RetVal2 = IE.document.getElementsByTagName("ziko")(1).ParentNode.innerText
    
    MsgBox RetVal1 & "  " & RetVal2
    
    IE.Quit
    Set IE = Nothing
End Sub

.

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
Acaba mgm'den ilçe bazında, hatta koordinat ile değer almak mümkün müdür?
Saygılarımla

 

[beab05]

Merhaba;

https://servis.mgm.gov.tr/web/merkezler?il=Ankara&ilce=Polatli

linki ile request ettiğinizde;

[
    {
        "alternatifHadiseIstNo": null,
        "boylam": 32.1624,
        "enlem": 39.5834,
        "gunlukTahminIstNo": 90622,
        "il": "Ankara",
        "ilPlaka": 6,
        "ilce": "Polatlı",
        "merkezId": 90622,
        "oncelik": 0,
        "saatlikTahminIstNo": null,
        "sondurumIstNo": 17728,
        "yukseklik": 886,
        "aciklama": "",
        "modelId": 110372,
        "gps": 1
    }
]

merkez id göreceksiniz..Burdan da

https://servis.mgm.gov.tr/web/sondurumlar?merkezid=90622

request ettiğinizde;

[
    {
        "aktuelBasinc": 918.8,
        "denizSicaklik": -9999,
        "denizeIndirgenmisBasinc": 1025.2,
        "gorus": 34410,
        "hadiseKodu": "CB",
        "istNo": 17728,
        "kapalilik": -9999,
        "karYukseklik": -9999,
        "nem": 65,
        "rasatMetar": "-9999",
        "rasatSinoptik": "-9999",
        "rasatTaf": "-9999",
        "ruzgarHiz": 11.520000000000001,
        "ruzgarYon": 311,
        "sicaklik": 2.6,
        "veriZamani": "2023-02-15T08:47:00.000Z",
        "yagis00Now": 0,
        "yagis10Dk": 0,
        "yagis12Saat": 0,
        "yagis1Saat": 0,
        "yagis24Saat": 0,
        "yagis6Saat": 0,
        "denizVeriZamani": "2023-02-15T08:47:00.000Z"
    }
]

göreceksiniz.

Ancak bu şekilde request ederken yani verileri isterken;

Headers için;

Host: servis.mgm.gov.tr

Origin: https://www.mgm.gov.tr

parametrelerini girmeniz gerekiyor yoksa veri alamazsınız.

Veriler JSON formatında gelmektedir. Bu şekilde daha kolay parse edilebilir ya da object key-value alarak en iyi şekilde de yapılabilir. Ben VBA tarafında çok uzak olduğum için @Haluk Üstat yardımcı olabilir belki..

 

[beab05]

Üstteki mesajıma ilave olarak test ettim. Aşağıdaki örnek kod yardımcı olabilir.

Sub HavaAl()

 

  Dim XMLHTTP As Object

  Set XMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")

  Dim myurl As String

  myurl = "https://servis.mgm.gov.tr/web/sondurumlar?merkezid=90622"

  XMLHTTP.Open "GET", myurl, False



  'XMLHTTP.setRequestHeader "Host", "servis.mgm.gov.tr"

  'host olmadan da veriyor..

 

  XMLHTTP.setRequestHeader "Origin", "https://www.mgm.gov.tr"

  XMLHTTP.send



 MsgBox (XMLHTTP.responseText)

' Debug.Print (XMLHTTP.responseText)

End Sub

Daha da kolaylaştırmak için JSON verilerle ilgili aşağıdaki linkten .bas dosyasını da projenize ekleyerek ilgili "key-value" leri alarak en iyi sonuçları elde edebilirsiniz.

GitHub - VBA-tools/VBA-JSON: JSON conversion and parsing for VBA

JSON conversion and parsing for VBA. Contribute to VBA-tools/VBA-JSON development by creating an account on GitHub.

github.com

 

[Haluk]

Sayın @beab05 'in önerdiği web servisten geri dönen JSon verilerini RegExp ile ayıklayarak kullanmak istersek;

Sub GetData_RegExp()
    ' Haluk - 15/03/2022
    '
    Dim strJSON As String, arrHeaders()
    Dim arrPattern(1 To 2) As String
    Dim regExp As Object, xPattern As Variant
    Dim r As Byte, c As Byte
    Dim myurl As String
    Dim XMLHTTP As Object
    
    Set XMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
    
    myurl = "https://servis.mgm.gov.tr/web/sondurumlar?merkezid=90622"
    
    XMLHTTP.Open "GET", myurl, False
    
    XMLHTTP.setRequestHeader "Origin", "https://www.mgm.gov.tr"
    
    XMLHTTP.send
    
    Range("A1:B" & Rows.Count) = ""
    
    strJSON = XMLHTTP.responseText
    arrHeaders = Array("RÜZGAR HIZI", "SICAKLIK")
    
    Range("A1:B1") = arrHeaders
    
    arrPattern(1) = """ruzgarHiz"":(.+?),""ruzgarYon"":"
    arrPattern(2) = """sicaklik"":(.+?),""veriZamani"":"
    
    Set regExp = CreateObject("VBScript.RegExp")
    
    regExp.ignorecase = True
    regExp.Global = True
    
    For Each xPattern In arrPattern
        regExp.Pattern = xPattern
        r = 1
        c = c + 1
        If regExp.Test(strJSON) Then
            For Each RetVal In regExp.Execute(strJSON)
                r = r + 1
                Cells(r, c) = RetVal.Submatches(0)
            Next
        End If
    Next
    
    MsgBox "Veriler alındı...", vbInformation
    
    Set regExp = Nothing
    Erase arrPattern
End Sub

.

 

[hgenc545]

Sub Test()
    Dim URL As String
    Dim IE As Object
   
    URL = "https://www.mgm.gov.tr/?il=ankara"
    Set IE = CreateObject("InternetExplorer.Application")
   
    IE.Visible = False
    IE.navigate URL
   
    Do Until IE.readyState = 4
    Loop
   
    RetVal1 = IE.document.getElementsByTagName("ziko")(0).innerText
    RetVal2 = IE.document.getElementsByTagName("ziko")(1).ParentNode.innerText
   
    MsgBox RetVal1 & "  " & RetVal2
   
    IE.Quit
    Set IE = Nothing
End Sub

.

Eline emeğine sağlık @Haluk üstad.. kodu bu halde getirebildim, çok teşekkürler..

 

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Ellerinize sağlık, paylaşır mısınız lütfen?
Saygılarımla

 

[ibere]

Teşekkür ederim.