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 |
Partager