AccessTr.neT

Tam Versiyon: web browser kullanımı
Şu anda arşiv modunu görüntülemektesiniz. Tam versiyonu görüntülemek için buraya tıklayınız.
Sayfalar: 1 2 3 4 5
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


Sayfalar: 1 2 3 4 5