• DİKKAT

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

otomatik tedaş fatura sorgulama ama nasıl?

Sayın msuphi;
İsteğiniz kodun şuan sadece sorgulama kısmını yazdım. Excele yazma kısmını elimde tedaştan sorgulayabileceğim fatura olmadığı için yazamıyorum.

o siteden sorgulayabileceğim bir abone bilgisi yazarsanız. excele kaydetme kısmını yazabilirim..

Kod: 
Sub Sorgula()
 
Dim IE As Object
adres = "http://hizmetler.tedas.gov.tr/TedasInternetIslemleri/BorcSorgulama/AboneBorcu.aspx"
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate adres
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
   
 For i = 2 To [sorgu!b65536].End(3).Row
    il = Sheets("sorgu").Range("b" & i)
 bolge = Sheets("sorgu").Range("c" & i)
  ilce = Sheets("sorgu").Range("d" & i)
kasaba = Sheets("sorgu").Range("e" & i)
   koy = Sheets("sorgu").Range("f" & i)
 abone = Sheets("sorgu").Range("g" & i)

With IE.Document.All
     .txtIlKodu.Value = il
     .txtIlBolgeKodu.Value = bolge
     .txtIlceKodu.Value = ilce
     .txtKasabaKodu.Value = kasaba
     .txtKoyKodu.Value = koy
     .txtAboneNo.Value = abone
      SendKeys IE.Document.GetElementById("btnBorcBul").Click()
End With
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
Next i
Set IE = Nothing
End Sub
 
ilginizden dolayı çok teşekkür ederim türk-x bir kaç tane abone örneği veriyorum bunları sırayla otomatik olarak nasıl sorgulatıp exele kaydedebiliriz.tabiki yüzlerce abneden sadece üçü var burda.
işlt.kodu abone no:
33.1.1.0.0 50000007830
33.1.6.0.0 50000001560
33.1.0.0.0 00000006370
 
vediğiniz numaraları şuan deneyemiyorum
tedaşın sitesi belli saatlerde işlem yapıyor sanırım
"Şu an işlem yapılamamaktadır.Lütfen daha sonra tekrar deneyiniz. " uyarısı veriyor.
o yüzden yarın sabahtan tekrar denemeye çalışacağım.
yada şu da olabilir.
sorgulama yapılmış bi sayfanın kaynak kodunu buraya yapıştırın
ona göre kodlama yapalım.
 
Yukarıdaki abone numalarının borç bilgisi çıkmıyor.
Borç bilgisi olan bir abone numarası yazarmısınız
veya
siz borç bilgisi olan bi abone numarası sorgulatın ve sorgulama sayfasının kaynak kodunu buraya yapıştırın.
hangisi kolayınıza gelirse onu yapın:D
 
Selam, ben kendi talebime göre aşağıdaki dosyayı düzenledim. Ancak çalıştıramıyorum. Birde gelen sonucu yine excel içinde bir hücreye yazdırmayı istiyorum.
Yardım edebilirmisiniz?
 

Ekli dosyalar

Slm;
hakanaga72 yapmak istediğinizin biraz daha detaylı bir çalışma yaptım. İşinizi fazlasıyla göreceğinden eminim.
Kodlar Aşağıda bu kodlamayı içeren dosyada ekte..

Kod: 
Sub Sorgula()
Sheets("sorgu").Range("C2:D" & [sorgu!c65536].End(3).Row).ClearContents
  Sheets("sorgu").Range("C2").Select
On Error Resume Next
 
Dim IE As Object
adres = "http://online.aydem.com/hizliborc.aspx"
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
For i = 2 To [sorgu!b65536].End(3).Row
IE.Navigate adres
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
   

    AboneNo = Sheets("sorgu").Range("b" & i)
    Sheets("sorgu").Range("C" & i) = "İşlem Sürüyor. Bekleyiniz..."
    

With IE.Document.All
     .txtAboneNo.Value = AboneNo
SendKeys IE.Document.GetElementById("imgbtnSorgula").Click()
End With

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

Set bak = IE.Document.getelementsbytagname("div")

'-----------//Gereksiz karakterleri temizle//--------------
Yaz = Replace(bak(1).innerhtml, "<B>", "")
Yaz = Replace(Yaz, "</B>", "")
Yaz = Replace(Yaz, "<BR>", "")

'----------/// Şimdide Abone Adı ve Borcu Ayırmak için metin kırpma yapalım.. ///-------------

Dim ara, nerede, ara2, ara3, nerede2, nerede3, yazi ' değişkenleri atayalım
yazi = Yaz 'Kesilecek metin
ara = "toplam" 'Aranacak 1. Metin
ara2 = ","     'Aranacak 2. Metin
ara3 = "borcunuz bulunmamaktadır."
nerede = InStr(yazi, ara) 'Yazi içinde 1. metni ara
nerede2 = InStr(yazi, ara2) 'Yazi içinde 2. metni ara
nerede3 = InStr(yazi, ara3) 'Yazi içinde 3. metni ara
If nerede3 Then
Kim = Replace(yazi, Left(yazi, nerede2 - 1), "") '2. metnin bitişini bul ve soldan kırp
Kim = Replace(yazi, Kim, "") 'metinden kırılan kısmı çıkar
Kim = Replace(Kim, "Sayın ", "") 'sayın kelimesini temizle
borc = "0,00"
Else
If nerede Then '1 Metin Bulunursa
'Karakter Temizleme Yapalım
borc = Replace(yazi, Left(yazi, nerede + 6), "") '1.metnin bitişini bul ve soldan kırp
borc = Replace(borc, "TL borcunuz bulunmaktadır.", "") 'Kalan karakterleri temizle
borc = Replace(borc, " ", "") 'Boşluğu da temizle ve rakam hazır
Kim = Replace(yazi, Left(yazi, nerede2 - 1), "") '2. metnin bitişini bul ve soldan kırp
Kim = Replace(yazi, Kim, "") 'metinden kırılan kısmı çıkar
Kim = Replace(Kim, "Sayın ", "") 'sayın kelimesini temizle

Else
borc = ""
Kim = "Abone Numarası Hatalı"
End If
End If

'-------------//Sayfaya Yaz//--------------------
Sheets("sorgu").Range("C" & i) = Kim
Sheets("sorgu").Range("D" & i) = borc * 1



Next i
Set IE = Nothing
MsgBox "Sorgulama işlemi Tamamlandı", vbInformation, "İŞLEM TAMAM"
End Sub
 

Ekli dosyalar

sayın turk-x size tedaşın kaynak kodlarını veriyorum yukarıdakine benzer bir sorgulamayı nasıl yapabiliriz tedaşın internet sitesi 6 sorgulamadan sonra başka sorgulama yapmaya izin vermiyor internet exploreri kapatıp açtığımızda sorgulama yapmak için tekrar 6 hakkımız oluyor bu konularda yeni olduğum için fazla soru soruyorum kusura bakmassınız herhalde yardımlarınız için çok teşekkür ederim.
 

Ekli dosyalar

Sayın msuphi ;
ben bi kaç gün önce deneme yaparken tedaşın sitesi sorunlu olduğu için sorgulama sorgulama yapamıyordum. Sizin verdiğiniz abone noları şimdi denediğimde hepsinde borç bilgi ekranın görebiliyorum
Ama
Şuan itibariyle hiçbir abonenin borcu yok
hatta sizin verdiğiniz sorgulama kodunda da borç tutarı yok.

eğer mümkünse borç bilgisi olan bir abonenin sorgulamasının kaynak kodunu ekleyin ki
bende ona göre bir kodlama yazayım.

Sitenin aynı pencerede 6 sorgulamadan fazlasına izin vermediğini daha önce farketmiştim. Onu basit bi döngü çözebilirim.
"Yeni olduğum için fazla soru soruyorum demişsiniz." Sormadan öğrenemezsiniz ki:D o yüzden kusura bakmam :D
 
öncelikle ilgilendiğiniz için çok teşekkür ederim size borç bilgisi olan bir abonenin kaynak kodlarını veriyorum.
 

Ekli dosyalar

Sayın msuphi dosya sorgulamada sorunsuz çalışıyor. Ama 6 Sorgu Engelini aşabilmiş değil. Eğer siz ie6 kullanıyorsanız sanırım bu sorun yaşanmaz bende ie 7 kurulu olduğu için explorer penceresi tamamen kapanmadan 6 sorgu sınırı aşılamıyor.

Siz bi deneyin ve bilgi verin olmazsa biraz araştırma yapar yinede çözüm üretirim.

Kod: 
Sub Sorgula()
On Error Resume Next
adres = "http://hizmetler.tedas.gov.tr/TedasInternetIslemleri/BorcSorgulama/AboneBorcu.aspx"
 For i = 3 To [sorgu!b65536].End(3).Row
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
IE.Navigate adres
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
    
    
    il = Sheets("sorgu").Range("B" & i)
 bolge = Sheets("sorgu").Range("C" & i)
  ilce = Sheets("sorgu").Range("D" & i)
kasaba = Sheets("sorgu").Range("E" & i)
   koy = Sheets("sorgu").Range("F" & i)
 abone = Sheets("sorgu").Range("H" & i)

Sheets("Sorgu").Range("J" & i) = "Sorgulama Yapılıyor... Bekleyiniz..."
 
With IE.Document.All
     .txtIlKodu.Value = il
     .txtIlBolgeKodu.Value = bolge
     .txtIlceKodu.Value = ilce
     .txtKasabaKodu.Value = kasaba
     .txtKoyKodu.Value = koy
     .txtAboneNo.Value = abone
      SendKeys IE.Document.GetElementById("btnBorcBul").Click()
End With
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

Set bak = IE.Document.getelementsbytagname("td")
AboneAdi = bak(16).innerhtml 'Abone Adı
   FatNo = bak(41).innerhtml 'Fatura No
SonOdeme = bak(43).innerhtml ' Son Ödeme Tarihi
    Borc = bak(44).innerhtml 'Borç Tutarı
   TBorc = bak(46).innerhtml 'Toplam Borç
   
Sheets("Sorgu").Range("J" & i) = Replace(Replace(AboneAdi, "<STRONG>", ""), "</STRONG>", "")
Sheets("Sorgu").Range("K" & i) = FatNo
Sheets("Sorgu").Range("L" & i) = SonOdeme
Sheets("Sorgu").Range("M" & i) = Borc
Sheets("Sorgu").Range("N" & i) = Replace(Replace(TBorc, " YTL.", ""), ".", ",")
IE.Quit
Set IE = Nothing
Next i


End Sub
 

Ekli dosyalar

Sayın turk-x ilginize çok teşekkürler.. İstediğimden iyi olmuş.
Ellerinize sağlık....
 
sonuçlar hep aynı çıkıyor

Ben deneme amaçlı yaptığımda ikinci sırada bulunan fatura bilgilerini doğru olarak girmeme rağmen, sorguladığımda sonuçlar hep aynı çıkıyor, doğru sonuç alan arkadaşımız varsa anlatabilirmi.
 

Ekli dosyalar

  • sorgusonucu.jpg
    sorgusonucu.jpg
    82.8 KB · Görüntüleme: 58
Hatanın sebebi abone numarasının eksik yazılıyor olması Abone No 11 hane olarak girilmesi gerekiyor aksi halde tedaş sitesi sorgulama yapmıyor.

Kodlamadaki :
abone = Sheets("sorgu").Range("H" & i) satırı abone = Format(Sheets("sorgu").Range("H" & i), "00000000000") olarak değiştirilirse program 11 haneyi kendisi tamamlar ve Sorun çözülür.

Düzeltilmiş dosyayı ekliyorum.
 

Ekli dosyalar

Çalışmada birkaç değişiklik

- Tedaş Sitesinin 6 Sorgu Engeli Aşıldı...
- Siteden Alınan Uyarı mesajlarının Sayfaya yazılması sağlandı...
-Sorgulamaya kaldığı yerden devam etme imkanı sağlandı...
- Az da olsa çalışmaya görsellik katıldı...
 

Ekli dosyalar

Son düzenleme:
sayın turk-x yazdığınız program için çok teşekkür ederim yalnız şöyle bir sorum olacak en son programda illaki abonelerin borç bilgisi olmasımı lazım yoksa olmasada olurmu birde programı denediğimde abone borç bilgisi olmayan ab onelerde ''site kaynaklı hata oluştu lütfen 10 dk bekleyin''mesajını gördüm bu normalmidir yoksa başka bir sebebimi vardır.
 
Abonelerin Borç Bilgisi olması şart değil eğer borcu yoksa borç kısmına sitede yer alan borcu yok bilgisi gelir. ''site kaynaklı hata oluştu lütfen 10 dk bekleyin'' mesajı hani olurda sitenin 6 sorgu engeline takılırsa diye koyduğum uyarıydı. Orda 6 Sorgu engelini aşmıştım. Hatta 80 tane sorgulama yapmıştım. ama demekki kodları düzenlerken gözden kaçırdığım bir kaç nokta oldu ki 6 sorgulama engeli yine karşımıza çıktı.
dosyayı tekrar gözden geçirip buraya ekleyeceğim.
 
Son Halini Ekliyorum.
ilave olarak süre bilgisi ekledim.
95 kayıt üzerinde deneme yaptım ve sorunsuz çalışıyor.
 

Ekli dosyalar

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