1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
| Option Explicit
Private Val1, Val2, T2, DV, DV_DB As Range
Private TFlag, Tc, Result, L1, N, J, K, timeout, ListMatos As Integer
Private LigneDouble As String
Private PresTrain As Object
Private TabMarche() As String
'Declaration MODE INTERNET EXPLORER
Const READYSTATE_COMPLETE = 4
Dim IEDoc As Object
Dim InputZoneText As Object
Dim InputCheckBox As Object
Dim InputButton As Object
Dim htmlTabElem() As Object
Public Ie As Object
'Declaration pour la fonction getElementsByClassName
Dim aElement As Object
Dim FuncElements() As Object
Dim SourceElem As Object
Dim GenericElement As Object
Dim iElem As Integer
Sub test()
Dim Ie As Object
Set Ie = CreateObject("InternetExplorer.application")
BotIE_CHTI Ie, "01/01/2014", "12/01/2014", "25"
End Sub
Public Function BotIE_CHTI(Ie As Object, DTrain As String, DateT As String, TLigne As Integer) As String
Dim Check2
Dim ValFin
Ie.Navigate "http://chti.sncf.fr/Marche.aspx"
WaitIE Ie
'"http://x64lmwbigf9/chtiV2.0/Marche.aspx"
Ie.Visible = False
'on attend que IE charge la page en entier
WaitIE Ie
'Init
Set IEDoc = Ie.Document
Dim Check As Object
Set Check = IEDoc.all("ctl00$ContentPlaceHolder1$tbLe")
If Not Check Is Nothing Then
Set InputCheckBox = IEDoc.all("ctl00$ContentPlaceHolder1$cbxSite")
If InStr(1, InputCheckBox.outerHTML, "CHECKED") <> 0 Then
InputCheckBox.Click
End If
Set InputCheckBox = IEDoc.all("ctl00$ContentPlaceHolder1$Période").Item(0)
InputCheckBox.Click
Set InputZoneText = IEDoc.all("ctl00$ContentPlaceHolder1$tbLe")
'Ecriture du train recherché dans le champ correspondant
InputZoneText.Value = DateT
Set InputZoneText = IEDoc.all("ctl00$ContentPlaceHolder1$tbMarche")
InputZoneText.Value = DTrain
'Identification du bouton et click
Set Check = IEDoc.all("ctl00$ContentPlaceHolder1$btVisualise")
If Not Check Is Nothing Then
Set InputButton = IEDoc.all("ctl00$ContentPlaceHolder1$btVisualise")
InputButton.Click
Set InputButton = IEDoc.all("ctl00$ContentPlaceHolder1$btnExport")
InputButton.Click
Do Until IEDoc.all("ctl00_ContentPlaceHolder1_lblRecherche").innerText <> vbNullString
DoEvents
Loop
Set Check2 = IEDoc.all("ctl00_ContentPlaceHolder1_gvMarche")
If Not Check2 Is Nothing Then
htmlTabElem = Ie.getElementsByClassName(IEDoc.all("ctl00_ContentPlaceHolder1_gvMarche").all.Item(0), "cssRow cssRowMarche", True)
WaitIE Ie
With ThisWorkbook.Worksheets("Tampon")
ValFin = .Range("A65536").End(xlUp).Row + 1
Application.ScreenUpdating = False
.Range("A" & ValFin).Value = htmlTabElem(0).all.Item(2).innerText
.Range("B" & ValFin).Value = htmlTabElem(0).all.Item(7).innerText
.Range("C" & ValFin).Value = htmlTabElem(0).all.Item(8).innerText
.Range("D" & ValFin).Value = htmlTabElem(0).all.Item(9).innerText
.Range("E" & ValFin).Value = htmlTabElem(0).all.Item(10).innerText
.Range("F" & ValFin).Value = htmlTabElem(0).all.Item(12).innerText
.Range("G" & ValFin).Value = htmlTabElem(0).all.Item(15).innerText
.Range("H" & ValFin).Value = CDate(DateT)
End With
With ThisWorkbook.ActiveSheet
.Range("B" & TLigne).Value = htmlTabElem(0).all.Item(7).innerText
.Range("C" & TLigne).Value = htmlTabElem(0).all.Item(9).innerText
.Range("D" & TLigne).Value = htmlTabElem(0).all.Item(8).innerText
Application.ScreenUpdating = True
End With
End If
End If
End If
Exit Function
End Function
Public Sub WaitIE(ByRef Ie As Object)
Dim lTimer As Double
Dim pTimeOut As Long
Dim TimeOutM As Boolean
pTimeOut = 10
lTimer = Timer
TimeOutM = False
'Sub d'attente Internet Explorer
Do Until Ie.readyState = READYSTATE_COMPLETE = 4
If (Timer - lTimer) > pTimeOut Then
TimeOutM = True
Exit Do
End If
Loop
If TimeOutM = False Then
Exit Sub
Else
MsgBox "Internet Explorer ou Chti ne répond plus !", vbCritical, "Erreur"
Ie.Quit
Set Ie = Nothing
End
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
With ThisWorkbook.ActiveSheet
If .Range("A" & Target.Row).Value <> vbNullString Then
If Target.Column = 1 And Target.Row > 15 Then
Set Ie = CreateObject("InternetExplorer.application")
Call BotIE_CHTI(Ie, .Range("A" & Target.Row).Value, .Range("J10").Value, Target.Row)
Ie.Quit
Set Ie = Nothing
On Error Resume Next
ThisWorkbook.ActiveSheet.Range("L" & Target.Row).Value = Time
ThisWorkbook.ActiveSheet.Range("M" & Target.Row).Value = Date
End If
End If
End With
End Sub |
