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
| Sub BtRecherche_Click()
Application.ScreenUpdating = False
AjoutReferences
Dim i As Integer
Dim Resultat As String
Dim ville As String
Dim appIE As InternetExplorer
Dim HTMLDoc As HTMLDocument
Dim oHTML_Element As IHTMLElement
Dim winShell As New ShellWindows
Dim sURL As String
Set appIE = New InternetExplorer
'Ancienne adresse
'sURL = "http://re.jrc.ec.europa.eu/pvgis/apps3/pvest.php?lang=fr&map=europe"
'Nouvelle adresse
sURL = "http://re.jrc.ec.europa.eu/pvgis/apps4/pvest.php"
appIE.Silent = True
appIE.Navigate sURL
appIE.Visible = True
Do 'Attend que la page soit bien chargée
Loop Until appIE.ReadyState = READYSTATE_COMPLETE
Set HTMLDoc = appIE.Document
' Liste des objets présents sur la page
i = 0
For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
Range("A" & 10 + i) = oHTML_Element.Type
Range("B" & 10 + i) = oHTML_Element.ID
Range("C" & 10 + i) = oHTML_Element.Title
Range("D" & 10 + i) = oHTML_Element.ClassName 'Tagname = "INPUT"
Range("E" & 10 + i) = oHTML_Element.getAttribute("Name")
i = i + 1
Next
Range("A" & 10 + i) = "terminé"
'Recherche la barre de texte et ecris l'adresse
For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
If oHTML_Element.getAttribute("name") = "address" Then oHTML_Element.setAttribute "value", "rouen": Exit For
Next
'Recherche du boutton "Search" et clic
For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
If oHTML_Element.getAttribute("value") = "Search" Then oHTML_Element.Click: Exit For
Next
Do 'Attend que la page soit bien chargée
Loop Until appIE.ReadyState = READYSTATE_COMPLETE
'Clic sur les CheckBox pour choisir les options
For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
If oHTML_Element.ID = "optrad" Then oHTML_Element.Click
If oHTML_Element.ID = "selectrad" Then oHTML_Element.Click
If oHTML_Element.ID = "optincl" Then oHTML_Element.Click
If oHTML_Element.ID = "degreedays" Then oHTML_Element.Click
Next
'Recherche du bouton "Calculer" et clic
For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
If oHTML_Element.ID = "MRchoicesubmit" Then oHTML_Element.Click: Exit For
Next
Do 'Attend que la page soit ouverte
Loop Until appIE.ReadyState = READYSTATE_COMPLETE
'Dim Cadre As Frame
'Recherche la bonne page et récupère les données
For Each appIE In winShell
If Right(appIE.LocationURL, 10) = "MRcalc.php" Then
appIE.Visible = True
Set HTMLDoc = appIE.Document
Resultat = HTMLDoc.documentElement.innerHTML
End If
Next appIE
ville = "Rouen"
'Mise en forme des données
MiseEnForme Resultat', ville
Range("A100") = Resultat
'Fermeture des fenetres
For Each appIE In winShell
If Left(appIE.LocationURL, 4) = "http" Then appIE.Quit
Next appIE
'appIE.Quit 'ferme les fenetres
Set appIE = Nothing
Application.ScreenUpdating = True
End Sub
'Ajout les références nécéssaires à l'utilisation de la macro
Sub AjoutReferences()
On Error GoTo Handler
ThisWorkbook.VBProject.References.AddFromFile ("C:\Windows\System32\mshtml.tlb") 'Microsoft HTML Object Library
ThisWorkbook.VBProject.References.AddFromFile ("C:\Windows\System32\shdocvw.dll") 'Microsoft internet Controls
Handler:
If Err.Number = 32813 Then
Else: MsgBox Err.Number & vbLf & Err.Description
End If
End Sub
Sub MiseEnForme(Buffer As Variant) ', ville As String)
Dim Tableau As String
Dim Longitude, Latitude As String
Dim Altiture, Inclinaison, Pombrage As Double
Dim Deb, Fin As Integer
'Recherche de la position
Deb = InStr(1, Buffer, "Location:")
Fin = InStr(Deb, Buffer, ",")
Latitude = Mid(Buffer, Deb + 10, Fin - Deb)
Deb = Fin
Fin = InStr(Deb + 1, Buffer, ",")
Longitude = Mid(Buffer, Deb, Fin - Deb)
End Sub |
Partager