AccessTr.neT

Sorudan anladığım kadarıyla

Sub WebVeri()

On Error Resume Next



    Dim IE As Object

    Dim HTML_Body As Object, HTML_Tables As Object, MyTable As Object

    Dim HTML_TableRows As Object

    Dim RetVal As Variant, X, A As Integer, SATIRSAYISI As Integer

        

        Set IE = Me.WebBrowser1

        Set HTML_Body = IE.Document.All

        Set HTML_Tables = HTML_Body.tags("Table")

        Set MyTable = HTML_Tables(41)

        

        Set HTML_TableRows = MyTable.GetElementsByTagName("tr")

        For Each MyRow In HTML_TableRows

            X = X + 1

        Next

        SATIRSAYISI = (X - 2) / 1

        

        ReDim Sorgu(7, SATIRSAYISI - 1)

        

        X = 0

        For X = 0 To SATIRSAYISI - 1

            A = 2 + (1 * X)

                                 

If MyTable.Rows(A).Cells(6).innerText = Empty Then



            Sorgu(0, X) = MyTable.Rows(A - 1).Cells(0).innerText

            Sorgu(1, X) = MyTable.Rows(A - 1).Cells(1).innerText

            Sorgu(2, X) = MyTable.Rows(A).Cells(0).innerText

            Sorgu(3, X) = MyTable.Rows(A).Cells(1).innerText

            Sorgu(4, X) = MyTable.Rows(A).Cells(2).innerText

            Sorgu(5, X) = MyTable.Rows(A).Cells(3).innerText

            Sorgu(6, X) = MyTable.Rows(A).Cells(4).innerText

            Sorgu(7, X) = MyTable.Rows(A).Cells(5).innerText

Else

                                 

           Sorgu(0, X) = MyTable.Rows(A).Cells(0).innerText

            Sorgu(1, X) = MyTable.Rows(A).Cells(1).innerText

            Sorgu(2, X) = MyTable.Rows(A).Cells(2).innerText

            Sorgu(3, X) = MyTable.Rows(A).Cells(3).innerText

            Sorgu(4, X) = MyTable.Rows(A).Cells(4).innerText

            Sorgu(5, X) = MyTable.Rows(A).Cells(5).innerText

            Sorgu(6, X) = MyTable.Rows(A).Cells(6).innerText

            Sorgu(7, X) = MyTable.Rows(A).Cells(7).innerText

           End If

         Next X



    Dim rc As DAO.Recordset

    Set rc = CurrentDb.OpenRecordset("tbl_bebek")

    

    X = 0

    

    For X = 0 To SATIRSAYISI - 1

    

        rc.AddNew

            rc![BEBEĞİNTCKİMLİKNOSU] = Sorgu(0, X)

            rc![BEBEĞİNADISOYADI] = Sorgu(1, X)

            rc![ASININADI] = Sorgu(2, X)

            rc![YAPILABİLECEĞİİLKTARİH] = Sorgu(3, X)

            rc![YAPILDIĞITARİH] = Sorgu(4, X)

            rc![YAPILABİLECEĞİSONTARİH] = Sorgu(5, X)

            rc![GEREKEN] = Sorgu(6, X)

            rc![YAPILAN] = Sorgu(7, X)

        rc.Update

    Next X

    

    Set rc = Nothing

    Me![tbl_bebek alt formu].Requery



        GoTo SafeExit:

'ErrHandler:

SafeExit:

    Set HTML_Body = Nothing

    Set HTML_Tables = Nothing

    Set MyTable = Nothing

    Set HTML_TableRows = Nothing

    Set HTML_TableDivisions = Nothing

    Set IE = Nothing

End Sub

şeklinde kod kullanılmalı.

vb sayfasına üst mesajdaki kodu ekleyin, üst mesajdaki kodun hemen altına

Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)

On Error Resume Next

Call WebVeri

End Sub

ayrıca komut butonu ekleyip tıklandığı olayına

WebBrowser1.Document.Forms(1).Item(4).Value = "xxxxxxxx- İSMAİL TÜRKKOL"

WebBrowser1.Document.Links.Item(41).OnClick

kodunu ekleyin. Bu şekilde butonu tıkladığınızda verileri tabloya aktarır.

Sonuç hakkında bilgi veriniz.

sayın admim elinize sağlık
hekim bilgisini ve tıklama olayını yapıyor
tam istediğim gibi
lakin hem komut29 hemde yeni eklediğim komut

If MyTable.Rows(A).Cells(6).innerText = Empty Then

satırı sarı olup hata veriyor

resimlerini ekliyorum

iyi günler arkadaşlar
sn.sledgeab
webbrowser örneği için çok teşekkürler
bu internet sayfasının gebe izlem detayında 16 kayıt var
bunları çok güzel alıp kaydediyor
fakat evdeki bilgisayarda bebek aşı tablosunuda alıyordu
laptopda sadece gebe izlem detayını alıyor
bebek aşı ve bebek izlem tablolarını almıyor

If MyTable.Rows(A).Cells(6).innerText = Empty Then

hatası veriyor
bu hata gebe izlem tablosunu alırken yok
daha önceden aşılarıda alıyordu şimdi almıyor
acaba sayfadaki tablo isimlerimi değişiyor
bunu kendim nasıl değiştirebilirim
veya tabloların satır sayıları değişince mi problem oluyor
mesela 16 gebe izleminde problem yokda 20 satır olduğunda bundada problem olabilir mi?
teşekkürler

Tablo isimlerinin değişmesi ile ilgisi yok. Kodda on error resume next yazıyorsa bu hatanın gelmemesi lazım.
1 bilgisayarda çalışıyor diğerinde çalışmıyorsa sorunu uygulamada aramak yersiz.

Ayrıca "Bebek İzlem Detayı" sekmesindeki verilerin aktarılması için kodun değiştirilmesi gerekli.

Uygulamanızda gerçek veriler olduğu için özel mesaj ile gönderdiğiniz uygulamanın son hali mail adresinize gönderildi.

Kodların tamamı şu şekilde

Option Compare Database

Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Function SendMessage Lib "user32" Alias _

        "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _

         ByVal wParam As Long, lParam As Any) As Long

Private Const WM_NCLBUTTONDOWN = &HA1

Private Const HTCAPTION = &H2

Private Sub accesstr_net_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

If Button = acLeftButton Then

ReleaseCapture

    SendMessage hwnd, WM_NCLBUTTONDOWN, _

        HTCAPTION, 0&

End If

End Sub



Private Sub Bebek_İzlem_Detayı_Click()

On Error Resume Next

WebBrowser1.Document.Links.Item(20).OnClick

Pause 2



WebBrowser1.Document.Forms(1).Item(4).Value = "19753768860 - İSMAİL TÜRKKOL"

WebBrowser1.Document.Links.Item(41).OnClick



Pause 2

Call WebVeri

End Sub



Private Sub Form_Load()



WebBrowser1.Navigate2 "http://is-zekasi.saglik.gov.tr/analytics/saw.dll?Dashboard&NQUser=19753768860&NQPassword=40BD001563085FC35165329EA1FF5C5ECBDBBEEF&PortalPath=/shared/Ahbs%20Raporlar%c4%b1/Page=hasta%20hareketleri&subject=performans"

End Sub



Sub WebVeri()

On Error Resume Next



    Dim IE As Object

    Dim HTML_Body As Object, HTML_Tables As Object, MyTable As Object

    Dim HTML_TableRows As Object

    Dim RetVal As Variant, x, A As Integer, SATIRSAYISI As Integer

        

        Set IE = Me.WebBrowser1

        Set HTML_Body = IE.Document.All

        Set HTML_Tables = HTML_Body.tags("Table")

        If Me.Metin40 = "Bebek İzlem Detayı" Then

        Set MyTable = HTML_Tables(43)

        Else

        Set MyTable = HTML_Tables(41)

        End If

        

        Set HTML_TableRows = MyTable.GetElementsByTagName("tr")

        For Each MyRow In HTML_TableRows

            x = x + 1

        Next

        SATIRSAYISI = (x - 2) / 1

        

        ReDim Sorgu(7, SATIRSAYISI - 1)

        

        x = 0

        For x = 0 To SATIRSAYISI - 1

            A = 2 + (1 * x)

                                 

If MyTable.Rows(A).Cells(6).Innertext = Empty Then



            Sorgu(0, x) = MyTable.Rows(A - 1).Cells(0).Innertext

            Sorgu(1, x) = MyTable.Rows(A - 1).Cells(1).Innertext

            Sorgu(2, x) = MyTable.Rows(A).Cells(0).Innertext

            Sorgu(3, x) = MyTable.Rows(A).Cells(1).Innertext

            Sorgu(4, x) = MyTable.Rows(A).Cells(2).Innertext

            Sorgu(5, x) = MyTable.Rows(A).Cells(3).Innertext

            Sorgu(6, x) = MyTable.Rows(A).Cells(4).Innertext

            Sorgu(7, x) = MyTable.Rows(A).Cells(5).Innertext

If Me.Metin40 = "Gebe İzlem Detayı" Then

            Sorgu(8, x) = MyTable.Rows(A).Cells(6).Innertext

End If

Else

                                 

           Sorgu(0, x) = MyTable.Rows(A).Cells(0).Innertext

            Sorgu(1, x) = MyTable.Rows(A).Cells(1).Innertext

            Sorgu(2, x) = MyTable.Rows(A).Cells(2).Innertext

            Sorgu(3, x) = MyTable.Rows(A).Cells(3).Innertext

            Sorgu(4, x) = MyTable.Rows(A).Cells(4).Innertext

            Sorgu(5, x) = MyTable.Rows(A).Cells(5).Innertext

            Sorgu(6, x) = MyTable.Rows(A).Cells(6).Innertext

            Sorgu(7, x) = MyTable.Rows(A).Cells(7).Innertext

If Me.Metin40 = "Gebe İzlem Detayı" Then

            Sorgu(8, x) = MyTable.Rows(A).Cells(8).Innertext

End If

           End If

         Next x



    Dim rc As DAO.Recordset

    

If Me.Metin40 = "Bebek Aşı Detayı" Then

    Set rc = CurrentDb.OpenRecordset("tbl_bebek_asi")

End If

If Me.Metin40 = "Bebek İzlem Detayı" Then

    Set rc = CurrentDb.OpenRecordset("tbl_bebek_izlem")

End If

    If Me.Metin40 = "Gebe İzlem Detayı" Then

    Set rc = CurrentDb.OpenRecordset("tbl_gebe_izlem")

End If

    x = 0

    

    For x = 0 To SATIRSAYISI - 1

    

        rc.AddNew



            

If Me.Metin40 = "Bebek Aşı Detayı" Then

            rc![BEBEĞİNTCKİMLİKNOSU] = Sorgu(0, x)

            rc![BEBEĞİNADISOYADI] = Sorgu(1, x)

            rc![ASININADI] = Sorgu(2, x)

            rc![YAPILABİLECEĞİİLKTARİH] = Sorgu(3, x)

            rc![YAPILDIĞITARİH] = Sorgu(4, x)

            rc![YAPILABİLECEĞİSONTARİH] = Sorgu(5, x)

            rc![GEREKEN] = Sorgu(6, x)

            rc![YAPILAN] = Sorgu(7, x)

End If

If Me.Metin40 = "Bebek İzlem Detayı" Then

            rc![BEBEĞİNTCKİMLİKNOSU] = Sorgu(0, x)

            rc![BEBEĞİNADISOYADI] = Sorgu(1, x)

            rc![BEBEĞİNDOĞUMTARİHİ] = Sorgu(2, x)

            rc![İZLEMİNYAPILABİLECEĞİİLKTARİH] = Sorgu(3, x)

            rc![İZLEMİNYAPILDIĞITARİH] = Sorgu(4, x)

            rc![İZLEMİNYAPILABİLECEĞİSONTARİH] = Sorgu(5, x)

            rc![GEREKEN] = Sorgu(6, x)

            rc![YAPILAN] = Sorgu(7, x)

End If



If Me.Metin40 = "Gebe İzlem Detayı" Then

            rc![GEBENİNTCKİMLİKNOSU] = Sorgu(0, x)

            rc![GEBENİNADISOYADI] = Sorgu(1, x)

            rc![GEBENİNSONADETTARİHİ] = Sorgu(2, x)

            rc![GEBELİKSONLANMATARİHİ] = Sorgu(3, x)

            rc![İZLEMİNYAPILABİLECEĞİTARİH] = Sorgu(4, x)

            rc![İZLEMİNYAPILDIĞITARİH] = Sorgu(5, x)

            rc![İZLEMİNYAPILABİLECEĞİSONTARİH] = Sorgu(6, x)

            rc![GEREKEN] = Sorgu(7, x)

            rc![YAPILAN] = Sorgu(8, x)

End If

        rc.Update

    Next x

    

    Set rc = Nothing

    Me![tbl_bebek alt formu].Requery

    Me.tbl_bebek_izlem_alt_formu.Requery

    Me.tbl_gebe_izlem_alt_formu.Requery



        GoTo SafeExit:

'ErrHandler:

SafeExit:

    Set HTML_Body = Nothing

    Set HTML_Tables = Nothing

    Set MyTable = Nothing

    Set HTML_TableRows = Nothing

    Set HTML_TableDivisions = Nothing

    Set IE = Nothing

End Sub

Public Sub Pause(duration As Long)

       Dim Current As Long

    Current = Timer

    Do Until Timer - Current >= duration

        DoEvents

    Loop

End Sub



Private Sub Komut32_Click()

On Error Resume Next

WebBrowser1.Document.Links.Item(19).OnClick

Pause 2



WebBrowser1.Document.Forms(1).Item(4).Value = "xxxxxxxxxxxxx - İSMAİL TÜRKKOL"

WebBrowser1.Document.Links.Item(41).OnClick



Pause 2

Call WebVeri

End Sub





Private Sub Komut43_Click()

On Error Resume Next

WebBrowser1.Document.Links.Item(21).OnClick

Pause 2



WebBrowser1.Document.Forms(1).Item(4).Value = "19753768860 - İSMAİL TÜRKKOL"

WebBrowser1.Document.Links.Item(41).OnClick



Pause 2

Call WebVeri

End Sub



Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)



On Error Resume Next

Me.Metin40 = WebBrowser1.Document.GetElementById("HighTab").Innertext



End Sub

Uygulama 5 bilgisayarda denenmiş, hepsinde de hata vermeden çalışmıştır.

iyi günler arkadaşlar
sn.admin
örneğinizi indirdim
ellerinize sağlık çok güzel olmuş
evdeki masaüstünde çok güzel çalışıyor
sadece

WebBrowser1.Document.Links.Item(41).OnClick

satırında hata veriyordu buda sizin bahsetmiş olduğunuz sitedeki nesnelerin değişmesinden kaynaklanan bir problem zannedersem
bunuda komutu ikiye bölerek hallettim

acaba bu koddaki (41) değerini kod kaynağının içinde nerede buluyoruz
onu öğrenirsem sizleri meşgul etmeden kendim düzeltme yaparım

bir ikincisi
masaüstünde gayet güzel çalışan program
laptopda 21.mesajda resmini eklediğim hatayı veriyor
elbette bu programın yapısından kaynaklanan bir problem değil
iki bilgisayar arasında nasıl bir fark var
bu hata niçin verilir
nasıl düzeltebilirim
masaüstünde sadece dediğim problem "..item(41).." var
ama laptop beni çıldırtmak üzere
ekte referans sayfasının resmi var
her ikisinde aynı office kurulu
laptop
windows vista home premium
masaüstü
windows 7 home premium
acaba nasıl çözüm bulabilirim
teşekkürler