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.
