VBA İle Web'de Veri Sorgulaması Yapıp Sonucunu Excel'e Çekme

ttnetttnet · 17 Eylül 2018

Merhabalar,
Ekte hazırladığım senaryoya göre bir web sitesinde sorgulama yapmak istiyorum.
Sorgulamanın sonucunda web sitesinde bir durum bilgisi belirecek.
Bu durum bilgisini de excel'e çekecek.

Çok uğraştım, fakat sanırım biryerde hata yapıyorum.

Siz değerli uzmanlarımızın dönüşünü bekliyorum.

Not: Daha detaylı anlatım için ütfen ekteki dosyayı inceleyin.

Saygılarımla,

ttnetttnet · 17 Eylül 2018

Merhaba,

Kendimce (hazır kodları da kullanarak) bir uyarlama yapmaya çalıştım. Dosyayı ekte iletiyorum.
Fakat, benim sorgulama yapmak istediğim internet sayfasında 2 sorgulama yeri ve 1 tane de sorguyu gerçekleştirmek için buton yer alıyor.
Yani yukarıya user id, aşağıya PIN kodu yazılması ve sonrasında da hemen altındaki yeşil renkli butona tıklanması gerekiyor.
Lütfen yardımınızı rica ediyorum.

Yaptığım çalışmayı ekte iletiyorum.

ttnetttnet · 17 Eylül 2018

Bu arada konuyla ilgili acil yardıma ihtiyacım var. Çokk teşekkür ediyorum şimdiden.

askm · 17 Eylül 2018

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

        If Target.Row = Range("Code").Row And _
            Target.Column = Range("Code").Column Then
            Dim IE As New InternetExplorer
                IE.Visible = True
                IE.navigate "http://publicbg.mjs.bg?reqnum=" & Range("Code").Value
            Do
                DoEvents
            Loop Until IE.readyState = READYSTATE_COMPLETE
            Dim Doc As HTMLDocument
            Set Doc = IE.document
            Dim sDD As String
                Doc.getElementById("ReqNum").Value = Range("Code").Value
                Doc.getElementById("PIN").Value = Range("PIN").Value
                Doc.getElementById("btnpdf").Click
                'sDD = Trim(Doc.getElementsByTagName("form")(1).innerText)
                'Range("B3").Value = sDD
        End If

End Sub

ttnetttnet · 18 Eylül 2018

askm' Alıntı:

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

        If Target.Row = Range("Code").Row And _
            Target.Column = Range("Code").Column Then
            Dim IE As New InternetExplorer
                IE.Visible = True
                IE.navigate "http://publicbg.mjs.bg?reqnum=" & Range("Code").Value
            Do
                DoEvents
            Loop Until IE.readyState = READYSTATE_COMPLETE
            Dim Doc As HTMLDocument
            Set Doc = IE.document
            Dim sDD As String
                Doc.getElementById("ReqNum").Value = Range("Code").Value
                Doc.getElementById("PIN").Value = Range("PIN").Value
                Doc.getElementById("btnpdf").Click
                'sDD = Trim(Doc.getElementsByTagName("form")(1).innerText)
                'Range("B3").Value = sDD
        End If

End Sub

Merhabalar,

Çok teşekkür ederim desteğiniz için

Yalnız durum şu ki; (ekte bir screenshot attım) Excel'de "KOD" kısmına ve "PIN" kısmına birşeyler yazacağım. Ardından yine Excel'deki "Çalıştır" butonuna tıklayacağım. Sonra ekteki screenshot'ta gösterdiğim gibi, ilgili web sitesine gidecek "public.mjs.bg" sonra ekte gösterdiğim kısımlara o kodları yazıp hemen altlarındaki yeşil butona basacak.

Ardından yukarıda Bulgarca dilinde

şeklinde bir durum bilgisi belirecek (Türkçesi "Veri Yok" anlamına geliyor).
Bu durum bilgisi normalde Internet Explorer'ın HTML sorgulamasında gözükmüyor. Ancak KOD ve PIN girilip yeşil butona basınca oluşuyor. Bu html kod satırının adı da aşağıda gösterdiğim gibi "font".

Buradan hareketle yardımınızı rica edeceğim

Çokk teşekkür ediyorum tekrardan.
Липсват данни

Haluk · 18 Eylül 2018

Biraz amatör işi kod oldu ama Bulgaristan Elçiliğinin web sayfasının yapısı da enterasan.... İstenilen oldu mu emin değilim .....

Kod:

Sub Test()
    Dim URL As String
    Dim IE As Object
    
    URL = "http://publicbg.mjs.bg/"
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Navigate URL
    
    Do Until IE.ReadyState = 4
    Loop
    
    IE.document.getElementsByName("RegNum")(0).Value = Range("B4")
    IE.document.getElementsByName("PIN")(0).Value = Range("B5")
    IE.document.getElementByID("btnpdf").Click
    
    Do Until IE.ReadyState = 4
    Loop
    
    Set Divisions = IE.document.getElementsByTagName("div")
    For Each Division In Divisions
        If Division.ID = "warnMsg" Then
            Range("B3") = Division.InnerText
        ElseIf Division.ID = "successMsg" Then
            Range("C3") = Division.InnerText
        End If
    Next

    IE.Quit
    Set IE = Nothing
End Sub

.

halit3 · 18 Eylül 2018

Merhaba tam olarak ne yapmak istediğinizi anlamadım ilgili linkte üç adet

Моля въведете Вашият входящ номер
Моля въведете Вашият входящ ПИН
Моля въведете Вашият номер на преписка

bunlar var yazmış olduğum kod buralara verileri giriyor ama verilermi yanlış bilmiyorum sonrasında hiç bir işlem olmuyor.

Rich (BB code):

Sub deneme1()
Dim URL As String
Dim IE As Object
URL = "http://publicbg.mjs.bg/"
Set IE = CreateObject("InternetExplorer.Application")

With IE
.Navigate URL
.Visible = 1
.Width = 800
.Height = 850
.Left = 10 '250
.Top = 0
Do Until IE.readyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

sat = 1
ReDim veri(3)

veri(1) = "12345/2016"
veri(2) = "12345"
veri(3) = "2016"

Set ElementCol = IE.document.getElementsByTagName("INPUT")
For Each link In ElementCol
If Len(link.Title) > 3 Then
link.Value = veri(sat)
Application.Wait (Now + TimeValue("0:00:01"))
sat = sat + 1
End If
Next link

Application.Wait (Now + TimeValue("0:00:02"))
'IE.document.forms(0).submit

Set IE = Nothing
End With


MsgBox ("Bitti  ")
End Sub

Haluk · 18 Eylül 2018

Bir ara da bunu deneyin ... gelen mesajlar Bulgarca olduğu için ne olduğunu anlamıyorum ....

Kod:

Sub Test2()
    Dim URL As String
    Dim IE As Object
   
    URL = "http://publicbg.mjs.bg/"
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Navigate URL
   
    Do Until IE.ReadyState = 4
    Loop
   
    IE.document.getElementsByTagName("INPUT")(3).Value = Range("B4")
    IE.document.getElementsByName("PIN")(0).Value = Range("B5")
    IE.document.getElementByID("btnpdf").Click
   
    Do Until IE.ReadyState = 4
    Loop
   
    Set Divisions = IE.document.getElementsByTagName("div")
    For Each Division In Divisions
        If Division.ID = "divProcessingEmbassy" Then
            Range("B3") = Division.InnerText
        ElseIf Division.ID = "warnMsg" Then
            Range("C3") = Division.InnerText
        ElseIf Division.ID = "successMsg" Then
            Range("C4") = Division.InnerText
        End If
    Next

    IE.Quit
    Set IE = Nothing
End Sub

.

ttnetttnet · 18 Eylül 2018

Haluk' Alıntı:

Bir ara da bunu deneyin ... gelen mesajlar Bulgarca olduğu için ne olduğunu anlamıyorum ....

Kod:

Sub Test2()
    Dim URL As String
    Dim IE As Object
  
    URL = "http://publicbg.mjs.bg/"
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Navigate URL
  
    Do Until IE.ReadyState = 4
    Loop
  
    IE.document.getElementsByTagName("INPUT")(3).Value = Range("B4")
    IE.document.getElementsByName("PIN")(0).Value = Range("B5")
    IE.document.getElementByID("btnpdf").Click
  
    Do Until IE.ReadyState = 4
    Loop
  
    Set Divisions = IE.document.getElementsByTagName("div")
    For Each Division In Divisions
        If Division.ID = "divProcessingEmbassy" Then
            Range("B3") = Division.InnerText
        ElseIf Division.ID = "warnMsg" Then
            Range("C3") = Division.InnerText
        ElseIf Division.ID = "successMsg" Then
            Range("C4") = Division.InnerText
        End If
    Next

    IE.Quit
    Set IE = Nothing
End Sub

.

Abi merhaba, çok teşekkürler öncelike. Bu kod dizilimi şu anda metodoloji olarak çok iyi çalışıyor.

Tek sorun; HTML'den

yazısını getirmesi gerekirken, bunun yerine

yazısını getiriyor.

yazısı normalde html kodlamasında çıkmıyor. Ne zamanki sisteme sorgulama yapılırsa sayfada bu yazı beliriyor, aynı zamanda htm kod diziliminde de oluşuyor. (sayfadaki aynı alanda bunun dışında başka durum mesajları da çıkabilir sorgulama sonucunda, fakat hepsi html kodlarında aynı satırda oluşuyor sorgulama sonrası.)

Aşağıda sorgulama sonrası oluşan html kodlarını iletiyorum. Yukarıdaki sarı renk ile boyadığım satır, benim sorgulama sonrası görüntülenmesini istediğim satır. Aşağıdaki sarı renkli satır ise, şu anda görünen satır.

Bu da hallolursa işlem tamam gibi.

Haluk · 18 Eylül 2018

Esasında bahsettiğin yazının C3 veya C4 hücresinde çıkması gerekir ama onun yerine sadece "!" çıkıyor.

Division tag'larının içinde "warnMsg" ve "successMsg" olanları C3 ve C4 hücrelerine yazdırıyor verdiğim kod ama dediğim gibi sadece "!" geliyor.

Bu arada, o çıkan mesajın Türkçesi nedir?

.

ttnetttnet · 18 Eylül 2018

halit3' Alıntı:
Merhaba tam olarak ne yapmak istediğinizi anlamadım ilgili linkte üç adet

Моля въведете Вашият входящ номер
Моля въведете Вашият входящ ПИН
Моля въведете Вашият номер на преписка

bunlar var yazmış olduğum kod buralara verileri giriyor ama verilermi yanlış bilmiyorum sonrasında hiç bir işlem olmuyor.

Rich (BB code):

Sub deneme1() Dim URL As String Dim IE As Object URL = "http://publicbg.mjs.bg/" Set IE = CreateObject("InternetExplorer.Application") With IE .Navigate URL .Visible = 1 .Width = 800 .Height = 850 .Left = 10 '250 .Top = 0 Do Until IE.readyState = 4: DoEvents: Loop Do While IE.Busy: DoEvents: Loop sat = 1 ReDim veri(3) veri(1) = "12345/2016" veri(2) = "12345" veri(3) = "2016" Set ElementCol = IE.document.getElementsByTagName("INPUT") For Each link In ElementCol If Len(link.Title) > 3 Then link.Value = veri(sat) Application.Wait (Now + TimeValue("0:00:01")) sat = sat + 1 End If Next link Application.Wait (Now + TimeValue("0:00:02")) 'IE.document.forms(0).submit Set IE = Nothing End With MsgBox ("Bitti ") End Sub

Abi merhaba,

Aşağıda özetlemeye çalıştım.

Aşağıda "1" ve "2" ile numaralandırdığım kısımlara sorgulancak kod ve pin giriliyor. Akabinde

olarak görünen butona tıklanıyor.
Sonrasında yukarıdaki

yazan bir not ortaya çıkıyor. (Burası değişken ve html kod diziliminde bulunmuyor, ancak sorgulama yapıldıktan sonra oluşuyor. Bu not yerine başka bir not da olabilir fakat hep aynı yerde ve aynı html satırında oluşuyor.)

ttnetttnet · 18 Eylül 2018

Haluk' Alıntı:
Esasında bahsettiğin yazının C3 veya C4 hücresinde çıkması gerekir ama onun yerine sadece "!" çıkıyor.

Bu arada, o çıkan mesajın Türkçesi nedir?

.

yazısının Türkçesi "Veri Yok" anlamına geliyor.
Normal şartlarda doğru kodu ve pin'i girince

yazısı çıkıyor. Bunun da Türkçesi "İsteğiniz, Vatandaşlık Konseyi tarafından olumlu görüşle değerlendirildi. Bulgaristan Cumhuriyeti Cumhurbaşkanı Yardımcısı"

Sizin ilettiğiniz kodları gömüp, Excel'de doğru kod ve pin'i girince yine aynı sonucu veriyor.

Doğru kod ve pin girdikten sonraki html kodlarını aşağıda iletiyorum;

Haluk · 18 Eylül 2018

Kod o dediklerini yapıyor ama sonuç beklendiği gibi gelmiyor.....

Bana doğru kod ve PIN'i özel mesajla yollarsan bakmaya çalışayım....

.

ttnetttnet · 18 Eylül 2018

Haluk' Alıntı:
Kod o dediklerini yapıyor ama sonuç beklendiği gibi gelmiyor.....

Bana doğru kod ve PIN'i özel mesajla yollarsan bakmaya çalışayım....

.

Özelden yazdım abi.

Haluk · 18 Eylül 2018

Maalesef olmadı .... daha önce dediğim gibi C3 veya C4 hücrelerinde mesaj çıkması lazım ama sadece "!" geliyor.

Muhtemelen sunucuya isteği yollarken bir çeşit Cookie falan da yollamak lazım........ uğraşmak gerekiyor.

.

ttnetttnet · 18 Eylül 2018

Haluk' Alıntı:
Maalesef olmadı .... daha önce dediğim gibi C3 veya C4 hücrelerinde mesaj çıkması lazım ama sadece "!" geliyor.

Muhtemelen sunucuya isteği yollarken bir çeşit Cookie falan da yollamak lazım........ uğraşmak gerekiyor.

.

Anladım. Çok teşekkür ederim. Hakikaten başlarken bu kadar kompleks olduğunu düşünmemiştim.
Yinede teşekkür ediyorum çok.
Esenlikler...

halit3 · 18 Eylül 2018

Bu kodu bir dene

PHP:

Private Sub CommandButton1_Click()
Dim URL As String
Dim IE As Object
URL = "http://publicbg.mjs.bg/"

Set IE = CreateObject("InternetExplorer.Application")

On Error Resume Next
With IE
.Navigate URL
.Visible = 1
.Width = 800
.Height = 850
.Left = 10
.Top = 0
Do Until IE.readyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

IE.document.getElementsByTagName("input")("ReqNum").Value = Cells(4, 2).Value
Application.Wait (Now + TimeValue("0:00:01"))
IE.document.getElementsByTagName("input")("PIN").Value = Cells(5, 2).Value
Application.Wait (Now + TimeValue("0:00:01"))
IE.document.getElementByID("btnpdf").Click
Application.Wait (Now + TimeValue("0:00:01"))

Set ElementCol = IE.document.getElementsByTagName("div")
For Each link In ElementCol
If link.ID = "warnMsg" Then
Cells(3, 2) = link.InnerText
End If
If link.ID = "successMsg" Then
Cells(3, 2) = link.InnerText
End If 
Next link

'ie.Quit:
Set IE = Nothing
End With


MsgBox ("Bitti  ")
End Sub

Haluk · 18 Eylül 2018

Evet, anlaşılan sorun 1 saniye kadar bekleme süresi ilave etmek gerkiyormuş .... gibi görünüyor.

Kod:

Sub Test3()
    Dim URL As String
    Dim IE As Object
    
    URL = "http://publicbg.mjs.bg/"
    
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Navigate URL
    
    Do Until IE.readyState = 4
    DoEvents
    Loop
    
    Do Until IE.Busy = False
    DoEvents
    Loop
    
    IE.document.getElementsByTagName("INPUT")(3).Value = Range("B4")
    IE.document.getElementsByName("PIN")(0).Value = Range("B5")
    IE.document.getElementByID("btnpdf").Click
    
    Application.Wait (Now + TimeValue("0:00:01"))
    
    Set divisions = IE.document.getElementsByTagName("div")
    
    For Each Division In divisions
        If Division.ID = "warnMsg" Then
            warnMsg = Division.InnerText
        ElseIf Division.ID = "successMsg" Then
            successMsg = Division.InnerText
        End If
    Next
    
    If Len(successMsg) > Len(warnMsg) Then
        Range("B3") = successMsg
    Else
        Range("B3") = warnMsg
    End If

    IE.Quit
    Set IE = Nothing
End Sub

.

ttnetttnet · 18 Eylül 2018

Haluk' Alıntı:

Evet, anlaşılan sorun 1 saniye kadar bekleme süresi ilave etmek gerkiyormuş .... gibi görünüyor.

Kod:

Sub Test3()
    Dim URL As String
    Dim IE As Object
  
    URL = "http://publicbg.mjs.bg/"
  
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Navigate URL
  
    Do Until IE.readyState = 4
    DoEvents
    Loop
  
    Do Until IE.Busy = False
    DoEvents
    Loop
  
    IE.document.getElementsByTagName("INPUT")(3).Value = Range("B4")
    IE.document.getElementsByName("PIN")(0).Value = Range("B5")
    IE.document.getElementByID("btnpdf").Click
  
    Application.Wait (Now + TimeValue("0:00:01"))
  
    Set divisions = IE.document.getElementsByTagName("div")
  
    For Each Division In divisions
        If Division.ID = "warnMsg" Then
            warnMsg = Division.InnerText
        ElseIf Division.ID = "successMsg" Then
            successMsg = Division.InnerText
        End If
    Next
  
    If Len(successMsg) > Len(warnMsg) Then
        Range("B3") = successMsg
    Else
        Range("B3") = warnMsg
    End If

    IE.Quit
    Set IE = Nothing
End Sub

.

İşte budur

Oldu bu iş!!! Çalıştı sonunda.
@Haluk abi, @Halit3 abi, çok sağolun. Tam bir takım oyunu oldu

Emeğinize sağlık.

Haluk · 18 Eylül 2018

Merhaba;

Web sayfalarından veri almak için yukarıdaki mesajlarda yer aldığı gibi Internet Explorer nesnesini kullanmak aslında hem kodların hızını oldukça azaltır, hem de ne zaman hata vereceği belli olmaz.... çeşitli sıkıntılar yaşanabilir. Bu nedenle yukarıda 6 No'lu mesajımda; "Biraz amatör işi kod oldu ama ..... " diye bir ifade kullanmıştım.

Dolayısıyle, mümkün mertebe Internet Explorer yerine XMLHTTP gibi nesnelerle çalışmak hem kodların daha hızlı çalışmasını sağlar, hem de daha güvenlidir.

Ekli dosyadaki veriler bu bahsettiğim şeklilde bir kod yapısıyla hızlıca alınmaktadır. Dosyadaki kodlarda RegNum ve PIN değerleri sayfanın dizayn edilmiş yapısı doğrultusunda JSon veri tipinde sunucuya gönderilip, yine JSon tipinde geri dönen cevap RegExp metodu ile ayıklanarak istenilen sonuç elde edilmektedir.

Sunucuya doğru değerler gönderildiğinde, ilgili mesaj alınmakta; yanlış değerler gönderildiğinde ise boş mesaj alınmaktadır.

Bu doğrultuda hazırlanan kodlar, ekli dosyadadır.

İyi akşamlar,

.

VBA İle Web'de Veri Sorgulaması Yapıp Sonucunu Excel'e Çekme

ttnetttnet

Ekli dosyalar

ttnetttnet

Ekli dosyalar

ttnetttnet

askm

Destek Ekibi

ttnetttnet

Haluk

𐱅𐰇𐰼𐰚

halit3

Uzman

Haluk

𐱅𐰇𐰼𐰚

ttnetttnet

Haluk

𐱅𐰇𐰼𐰚

ttnetttnet

ttnetttnet

Haluk

𐱅𐰇𐰼𐰚

ttnetttnet

Haluk

𐱅𐰇𐰼𐰚

ttnetttnet

halit3

Uzman

Haluk

𐱅𐰇𐰼𐰚

ttnetttnet

Haluk

𐱅𐰇𐰼𐰚

Ekli dosyalar