• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Web Sitesindeki Veriye Göre Mesaj verme

  • Konbuyu başlatan Konbuyu başlatan BedriA
  • Başlangıç tarihi Başlangıç tarihi
B

BedriA

Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Değerli Arkadaşlar,

Excel 2007 ile yaptığım projemde, internet sitemdeki bir veriye göre güncelleme uyarısı vermek istiyorum.

Bunu yapmak mümkün mü? Mümkünse nasıl?

Cevaplarınız için şimdiden teşekkürler.
 
Öncelikle web sitesinden veri çekmeniz gerekli. Çekilen veri kriterinize uyuyorsa MsbBox verirsiniz.
 
Bütün sitelerde dışardan veri al çalışmaz. Site kodları incelenerek kod yazılıp sadece istenilen veriler çekilebilir.
 
Sayın BedriA
Bahsettiğiniz site adresi ve almak istediğiniz veri hakkında açıklama yaparsanız konu daha çabuk sonuçlanacaktır.
 
BedriA' Alıntı:
Değerli Arkadaşlar,

Excel 2007 ile yaptığım projemde, internet sitemdeki bir veriye göre güncelleme uyarısı vermek istiyorum.

Bunu yapmak mümkün mü? Mümkünse nasıl?

Cevaplarınız için şimdiden teşekkürler.
Genişletmek için tıkla ...

Örnek kodları inceleyiniz.

Bu kod excel.web.tr deki en güncel mesajın tarihini kontrol eder. Değişiklik var ise uyarı verir.


Kod: 
[COLOR=Red]'Excel VBA reference de Windows WinHttpRequest seçili olmalı.[/COLOR]
Public Sub Web_Sayfasi_Kontrol()
    Dim oHttp As New WinHttp.WinHttpRequest
    Dim sURL As String
    Dim veri As String
    
   'Eski okunan bilginin kaydedildiği hücre
    eskibilgi = Cells(1, "A").Value
    
    'Hangi web sitesinden verinin okunacağı
    sURL = "http://www.excel.web.tr"

    oHttp.Open "GET", sURL, False
    oHttp.Send
    veri = oHttp.ResponseText
        
    If veri <> "" Then

       'Veriye yakın bir bezersiz alan. HTML kodlarından bulunur.
       aranan = "title1=""Tarih/Saat"

       basla = InStr(veri, aranan)
       If basla > 0 Then
          'MsgBox (Mid(veri, basla, Len(veri)))
          
          'İlk eleme sonrası veriden önce veriye en yakın bilgi 
          veri = Mid(veri, InStr(veri, [COLOR=red][B]"time""[/B]>"[/COLOR]) + 6, Len(veri))
          
           'Veriden sonra gelen bilgi.
          yenibilgi = Mid(veri, 1, InStr(veri, [COLOR=red]"<"[/COLOR]) - 1)

          If eskibilgi <> yenibilgi Then
             MsgBox ("Yeni mesaj var.")
             'Güncel bilgi A1 e yazılıyor.
             Cells(1, "A").Value = yenibilgi
          End If
       End If
    End If
           
End Sub
 
Excelmy' Alıntı:
Sayın BedriA
Bahsettiğiniz site adresi ve almak istediğiniz veri hakkında açıklama yaparsanız konu daha çabuk sonuçlanacaktır.
Genişletmek için tıkla ...

İlginiz için teşekkür ederim.

Veri alacağım site, Wix ile hazırladığım bir site.
Almak istediğim veri logo kısmında yazan "Azmun V2.2" ifadesi...

O ifade programın içindeki ifadeden farklı ise kullanıcı güncelleme uyarısı alacak.

Veri alınacak site.
 
asri' Alıntı:
Örnek kodları inceleyiniz.

Bu kod excel.web.tr deki en güncel mesajın tarihini kontrol eder. Değişiklik var ise uyarı verir.


Kod: 
[COLOR=Red]'Excel VBA reference de Windows WinHttpRequest seçili olmalı.[/COLOR]
Public Sub Web_Sayfasi_Kontrol()
    Dim oHttp As New WinHttp.WinHttpRequest
    Dim sURL As String
    Dim veri As String
    
   'Eski okunan bilginin kaydedildiği hücre
    eskibilgi = Cells(1, "A").Value
    
    'Hangi web sitesinden verinin okunacağı
    sURL = "http://www.excel.web.tr"

    oHttp.Open "GET", sURL, False
    oHttp.Send
    veri = oHttp.ResponseText
        
    If veri <> "" Then

       'Veriye yakın bir bezersiz alan. HTML kodlarından bulunur.
       aranan = "title1=""Tarih/Saat"

       basla = InStr(veri, aranan)
       If basla > 0 Then
          'MsgBox (Mid(veri, basla, Len(veri)))
          
          'İlk eleme sonrası veriden önce veriye en yakın bilgi 
          veri = Mid(veri, InStr(veri, [COLOR=red][B]"time""[/B]>"[/COLOR]) + 6, Len(veri))
          
           'Veriden sonra gelen bilgi.
          yenibilgi = Mid(veri, 1, InStr(veri, [COLOR=red]"<"[/COLOR]) - 1)

          If eskibilgi <> yenibilgi Then
             MsgBox ("Yeni mesaj var.")
             'Güncel bilgi A1 e yazılıyor.
             Cells(1, "A").Value = yenibilgi
          End If
       End If
    End If
           
End Sub
Genişletmek için tıkla ...

Asri Hocam,

Teşekkür ederim.
 
Aşağıdaki kodu deneyiniz;

Kod: 
Sub Test()
        Dim W As Object
        Dim URL As String
        URL = "https://bedriadanir.wixsite.com/azmun"
        
        On Error Resume Next
            Set W = CreateObject("winhttp.winhttprequest.5")
            If Err.Number <> 0 Then
                Set W = CreateObject("winhttp.winhttprequest.5.1")
            End If
        On Error GoTo 0
        
        On Error Resume Next
        
        W.Open "GET", URL, False
        W.Send
        If Err Then
            MsgBox "Sunucu cevap vermedigi icin veri alinamiyor...", vbCritical
            Exit Sub
        End If
       
        Temp = W.ResponseText
        
        
        str1 = "<title>"
        str2 = "</title>"
        
        x1 = InStr(Temp, str1)
        x2 = InStr(Temp, str2)
        
        x = Mid(Temp, x1 + Len(str1), x2 - x1 - Len(str2) + 1)
        
        x = Replace(x, "û", "û")
        
        MsgBox "Sitenin ''Title'' bölümünde " & x & " ifadesi bulundu"
        Set W = Nothing
End Sub
 
Haluk' Alıntı:
Aşağıdaki kodu deneyiniz;

Kod: 
Sub Test()
        Dim W As Object
        Dim URL As String
        URL = "https://bedriadanir.wixsite.com/azmun"
        
        On Error Resume Next
            Set W = CreateObject("winhttp.winhttprequest.5")
            If Err.Number <> 0 Then
                Set W = CreateObject("winhttp.winhttprequest.5.1")
            End If
        On Error GoTo 0
        
        On Error Resume Next
        
        W.Open "GET", URL, False
        W.Send
        If Err Then
            MsgBox "Sunucu cevap vermedigi icin veri alinamiyor...", vbCritical
            Exit Sub
        End If
       
        Temp = W.ResponseText
        
        
        str1 = "<title>"
        str2 = "</title>"
        
        x1 = InStr(Temp, str1)
        x2 = InStr(Temp, str2)
        
        x = Mid(Temp, x1 + Len(str1), x2 - x1 - Len(str2) + 1)
        
        x = Replace(x, "û", "û")
        
        MsgBox "Sitenin ''Title'' bölümünde " & x & " ifadesi bulundu"
        Set W = Nothing
End Sub
Genişletmek için tıkla ...

Çok teşekkür ederim Haluk hocam.
İstediğim buydu tam olarak.

Sağolun.
 
Rica ederim, Diyarbakır'a selamlar ....

.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst