recup donnée internet transfert de question de THAHARDY

Version imprimable

Voir 40 message(s) de cette discussion en une page

Bonjour thahardy
je post la réponse a ta demande sur un nouveau post
et a l'avenir évite de polluer le fil d'une autre discussion
merci de ta compréhension

voila ton code
j'ai modifié la wait IE ,on oublie souvant le "IE.busy"
en effet parfois le readystate nous donne la main mais la page travaille encore

j'ai modifié l'utilisation de l'object IE maintenant en late binding afin d'avoir un fichier transportable et utilisable sur tout ordi avec exel 2003 minimum sans avoir de références a activer
j'ai tronqué aussi l'utilisation de variable object (famille "IE") pas necessaire dans ce cas présent

j'ai mis quelques commentaire qui t'aideront a comprendre le fonctionnement ;)

Code:

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
Option Explicit
Sub WaitIE(IE As Object)
'On boucle tant que la page n'est pas totalement chargée
    Do: DoEvents: Loop While IE.readystate <> 4 Or IE.busy
End Sub
Sub RechercheVBAExcel()
'Déclaration des variables
    Dim IE As Object, matable As Object, i As Long, lignes As Object, valeur As String
    Set IE = CreateObject("internetexplorer.application")
    IE.navigate "www.google.com/finance"    'Chargement d'une page Web Google
    IE.Visible = True
    'Affichage de la fenêtre IE
    WaitIE IE    'On attend le chargement complet de la page
    With IE.document
        .all("q").Value = "VSAR"    'on inscrit le texte dans le textbox "q"
        .all("gbqfb").Click    'On click sur le  bouton
        WaitIE IE
        Set matable = .getelementsbyclassname("snap-data")(0)    'on recupere la table concernée par sa classe ,c'est la 1 ere donc l'index 0  !!!
        Set lignes = matable.getelementsbytagname("tr")    'on prent les lignes complete du tableau
        For i = 0 To lignes.Length - 1
            'on test si la premiere cellule de chaque ligne est ecrit "Mkt cap" si oui la valeur est la 2 eme cellule  de la meme ligne
            If RTrim(lignes(i).Children(0).innertext) = "Mkt cap" Then valeur = lignes(i).Children(1).innertext
        Next
    End With
    IE.Quit
    Set IE = Nothing 'On libère la variable "IE"
 
    MsgBox valeur
    End Sub

quand on utilise l'espion f12 de IE on remarque quelques petits détails for intéressants

il y a moyen de simplifier ta procédure
en effet plutôt que d'aller sur la page d'accueil "finance "
on peut mettre les argument directement dans l'url avec Google c'est souvent comme ca
donc on peut utiliser l'url comme ceci:

Citation:

http://www.google.com/finance?q=VSAR

ainsi on a plus a marquer et cliquer puisque l'on tombe sur la page de "VSAR" directement
ensuite dans le précèdent exemple je prenais la table puis disséquais les lignes
maintenant on prend toutes les lignes de toutes les table de la page web
et on teste son intitulé
et le tour est joué
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Sub test() Dim IE As Object, matable As Object, i As Long, lignes As Object, valeur As String Set IE = CreateObject("internetexplorer.application") IE.navigate "http://www.google.com/finance?q=VSAR" 'Chargement d'une page Web Google" IE.Visible = True 'Affichage de la fenêtre IE WaitIE IE 'On attend le chargement complet de la page With IE.document Set lignes = .getelementsbytagname("tr") 'on prend toutes les lignes de toutes les tables de la page web For i = 0 To lignes.Length - 1 'on test si la premiere cellule de chaque ligne est ecrit "Mkt cap" si oui la valeur est la 2 eme cellule de la meme ligne If RTrim(lignes(i).Children(0).innertext) = "Mkt cap" Then valeur = lignes(i).Children(1).innertext Next End With IE.Quit Set IE = Nothing 'On libère la variable "IE" MsgBox valeur End Sub Sub WaitIE(IE As Object) 'On boucle tant que la page n'est pas totalement chargée Do: DoEvents: Loop While IE.readystate <> 4 Or IE.busy End Sub
beaucoup plus simple non???;)

08/06/2015, 12h09
ThaHardy

1 pièce(s) jointe(s)

Tout d'abord un GRAND merci pour ton aide patricktoulon!
Et permet moi de m'excuser pour la polution d'autre discussions mais je ne savais pas trop ou poster ma question..

Ensuite effectivement dans l'idée la deuxieme solution semble plus simple cependant la recherche "VSAR" que j'avais mis au moment de commencer mon code n'était que pour tester que ce dernier fonctionnait correctement.
Je n'aurais qu'une question; comment puis-je faire pour qu'au lieu d'avoir VSAR comme recherche comment faire pour que la recherche soit faite avec la valeur contenu dans un champs (ici le nom de sociétés enregistré dans la base) et qu'a chaque fois on extrait la valeur Market Cap de la page IE pour la rentrer/modifier dans un autre champs de la table ou on est aller chercher le texte de la recherche ?
Je ne sais pas si j'ai ete clair mais globalement cela serait pour mettre a jour la Market cap de chaque companie enregistré dans la base. L'idée serait a termes que les market Cap soient mis a jour a chaque ouverture de la base.
Etant tout a fait nouveau dans le domaine soyez un peu indulgent si mes questions vous semble simplissime.. :?

Cordialement
TH

Re-bonjour,
Je répete que je suis tout a fait nouveau en VBA et Access, Mais quand je run la Macro voila ce que j'obtiens ..

Cordialement

Bonjour ta capture d'écran montre que tu utilise la méthode 1
perso je préfère la 2 elle est plus généraliste

et pour ton problème de variable "vsar" et autre
voici un exemple qui boucle sur une plage "a1:a10" et envoie dans l"url l'argument
en retour la cellule juste a coté et a droite reçoit la valeur

mais cependant si tu dois en avoir beaucoup je te suggère d'utiliser une requête (beaucoup plus rapide )
voici un exemple avec 10 valeur a trouver a toi de mettre ces valeur en colonne A

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub test()
  Set plage = Range("A1:A10")
 
    For Each cel In plage.Cells
    Dim IE As Object, matable As Object, i As Long, lignes As Object, valeur As String
    Set IE = CreateObject("internetexplorer.application")
    IE.navigate "http://www.google.com/finance?q=" & cel.Value  'Chargement d'une page Web Google"
    IE.Visible = True    'Affichage de la fenêtre IE
    WaitIE IE    'On attend le chargement complet de la page
 
    With IE.document
         Set lignes = .getelementsbytagname("tr")    'on prend toutes les lignes de toutes les tables de la page web
        For i = 0 To lignes.Length - 1
            'on test si la premiere cellule de chaque ligne est ecrit "Mkt cap" si oui la valeur est la 2 eme cellule  de la meme ligne
            If RTrim(lignes(i).Children(0).innertext) = "Mkt cap" Then valeur = lignes(i).Children(1).innertext
        Next
    End With
    IE.Quit
    Set IE = Nothing    'On libère la variable "IE"
   cel.Offset(0, 1) = valeur
next
End Sub

sinon comme ca vite fait un exemple avec une requête admire la rapidité

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub par_requete()
    Dim REQ, URL,i,a
    URL = "http://www.google.com/finance?q=VSAR"
    Set REQ = CreateObject("microsoft.xmlhttp")
    REQ.Open "POST", URL, False
    REQ.setRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"
    REQ.send
       With CreateObject("htmlfile")
        .write REQ.responsetext
        Set meslignes = .getelementsbytagname("TR")
        For i = 0 To meslignes.Length - 1
            For a = 0 To meslignes(i).Children.Length - 1
                 If meslignes(i).Children(a).innertext = "Mkt cap " Then valeur = meslignes(i).Children(a + 1).innertext
            Next
        Next
    End With
    MsgBox valeur
set REQ=nothing
End Sub

;)

09/06/2015, 10h31
ThaHardy

Re

Bonjour,
Merci c'est sympa je vais essayer ca tout de suite.
Juste pour etre sur; je peux utiliser la méthode de plage sur ACCESS 2010 également?
Si oui;
- Comment sélectionner la colone dans la table ou se trouve la variable ?
- Comment demander a la Macro de placer la valeur trouvée dans une autre cellule de cette meme table mais sur la meme ligne ou le code a pris la variable bien évidemment ?

Car j'ai l'impression que ton code ne marche pas sur ACCESS ou bien j'ai commis une erreur quelque part, mais dans ce cas je ne sais pas ou..

En tout cas merci de ton aide précieuse !

Cordialement

TH
09/06/2015, 11h04
patricktoulon

re

salut thahardy

non pas sur accès a vrai dire tu est sur le forum "vba Excel" ici ;)

mais mis a part la sélection de cellule pour le reste ca ne doit pas trop changer
je ne m'y suis jamais intéressé je vais regarder un peu sur acces ;)
09/06/2015, 11h17
ThaHardy

Re

ah okay, je sais pas trop comment j'ai atterit sur le VBA excel, excuse moi si je pollue du coup :?
Oui je pense que cela ne differe pas trop mais je t'avoue n'avoir aucune idée de comment faire ma selection et de comment renvoyer la valeur dans la cellule voulu..

Merci pour l'interet que tu portes a mon probleme !

Bien Cordialement

TH

J'implémente la solution de PatrickToulon dans access (Forum différent mais pour dépanner)

Si la table nommée maTable contient entre autre les champs MonTitre (le titre à chercher), MaValeur (la valeur à récupérer), MaDate (la date de mise à jour)

Dans un formulaire avec un bouton nommé btnremplir, mettre le code

Code:

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
Option Compare Database
Option Explicit
 
Private Sub BtnRemplir_Click()
Dim SetA As Object
Dim LaValeur As String
 
Set SetA = CurrentDb.OpenRecordset("MaTable", dbOpenTable)
With SetA
    Do Until .EOF
        LaValeur = MktCap(!MonTitre)
        .Edit
        !MaValeur = LaValeur
        !MaDate = Now()
        .Update
        .MoveNext
    Loop
    .Close
End With
Set SetA = Nothing
MsgBox "Terminé"
End Sub
 
Private Function MktCap(ByVal Titre As String) As String
Dim REQ As Object, HTML As Object, MesLignes As Object
Dim URL As String, Txt As String, Valeur As String
Dim i As Long, a As Long
Dim Fin As Boolean
 
URL = "http://www.google.com/finance?q=" & Titre
Set REQ = CreateObject("microsoft.xmlhttp")
With REQ
    .Open "POST", URL, False
    .SetRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"
    .Send
    Txt = .ResponseText
End With
Set REQ = Nothing
 
Set HTML = CreateObject("htmlfile")
With HTML
    .Write Txt
    Set MesLignes = .GetElementsByTagName("TR")
    For i = 0 To MesLignes.Length - 1
        For a = 0 To MesLignes(i).Children.Length - 1
            If MesLignes(i).Children(a).InnerText = "Mkt cap " Then
                MktCap = MesLignes(i).Children(a + 1).InnerText
                Fin = True
                Exit For
            End If
        Next a
        If Fin Then Exit For
    Next i
    Set MesLignes = Nothing
    .Close
End With
Set HTML = Nothing
End Function

Bonjour Mercatog

tu peux dépanner tant que tu veux au contraire j'apprend moi aussi je ne l'ai jamais fait avec accès

et c'est en regardant ton code que je me suis rendu compte que je faisait des détours pour rien avec ma double boucle imbriquée
en fait cela suffit puisque on se repère au 1 er enfant de la ligne dans la table
Code:

1 2 3 4 5 6 7 With CreateObject("htmlfile") .write REQ.responsetext Set meslignes = .getelementsbytagname("TR") For i = 0 To meslignes.Length - 1 If meslignes(i).Children(0).innertext = "Mkt cap " Then valeur = meslignes(i).Children(1).innertext Next End With

11/06/2015, 11h52
ThaHardy

Bonjour,
Mercatog tu es tout simplement génial !!! Une reponse claire et consise dont j'ai pu appliquer le contenu en 5 min avec un résultat qui marche a merveille !! MERCI BEAUCOUP :D:D;)
Merci également a toi patricktoulon pour l'interet que tu as porté a mon probleme !

Du coup j'aurai aimer savoir si tu pouvais détailler le code pour bien comprendre chaque étape du code pour que je puisse le réutiliser a l'occcasion ?
Merci d'avance

Trés cordialement !

TH

Bonjour,
mercatog je voulais te remercier une fois deplus pour ton aide.
Si je reposte aujourd'hui c'est parceque j'ai eu besoin a nouveau d'utiliser "le meme code" pour faire la meme mise a jour sur google finance encore une fois, mais cette fois ci c'est pour avoir la valeur de différentes Devises/Monnaies en USDollar. ( pour le faire j'ai créer une table Currency comportant un champs Currency un champs CurrencyToDollar et un champs CurrencyRateDate ainsi qu'un ID)
Du coup j'ai essayé de comprendre et d'adapter le code; voila ce que j'ai:
Code:

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 Option Compare Database Option Explicit Private Sub BtnCurrency_Click() Dim SetA As Object Dim LaValeur As String Set SetA = CurrentDb.OpenRecordset("TBLCurrency", dbOpenTable) With SetA Do Until .EOF LaValeur = Rate(!Currency) .Edit ![CurrencyToDollar] = LaValeur ![CurrencyRateDate] = Now() .Update .MoveNext Loop .Close End With Set SetA = Nothing MsgBox "Currency Rates have been updated with success" End Sub Private Function Rate(ByVal Currency_Rate As String) As String Dim REQ As Object, HTML As Object, MesLignes As Object Dim URL As String, Txt As String, Valeur As String Dim i As Long, a As Long Dim Fin As Boolean URL = "http://www.google.com/finance?q=" & Currency_Rate Set REQ = CreateObject("microsoft.xmlhttp") With REQ .Open "POST", URL, False .setRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)" .send Txt = .responseText End With Set REQ = Nothing Set HTML = CreateObject("htmlfile") With HTML .Write Txt Set MesLignes = .getElementsByTagName("class") For i = 0 To MesLignes.length - 1 For a = 0 To MesLignes(i).Children.length - 1 If MesLignes(i).Children(a).innerText = "bld" Then Rate = MesLignes(i).Children(a + 1).innerText Fin = True Exit For End If Next a If Fin Then Exit For Next i Set MesLignes = Nothing .Close End With Set HTML = Nothing End Function
Cependant cela ne fonctionne pas (Si j'ai bien compris le code Je pense que c'est parceque je ne trouve pas le texte qui se trouve avant le sous menu ou se trouve la valeur) je n'ai que la date qui rentre dans la table ...

Voila donc si vous avez une idée de mon probleme ca serait génial !!

Merci d'avance pour votre aide.

Cordialement

TH

12/06/2015, 21h09
patricktoulon

re

bonjour
pour la requête a mon avis ca doit venir de la

Code:

Set MesLignes = .getElementsByTagName("class")

c'est bien la premiere fois que je verrais un élément html avoir

Citation:

class="class"

entre nous
je pense que tu fait l'amalgame entre la propriété "classname" et et la fonction elle même
quand on se sert de cette fonction c'est le nom de la class pas la propriété "class"
Set MesLignes = .getElementsByTagName("class")[/CODE]
a mon avis c'est bien de la que ca vient
car ca violerait toute les règles du développeur "utiliser une expression comme un string""
et cela m'étonnerait beaucoup !!
Au plaisir

Il suffit de chercher l'info désirée dans la variable Txt

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Function Rate(ByVal Currency_Rate As String) As Variant 'Ou bien As Single
Dim URL As String, Txt As String, TxtRate As String
Dim REQ As Object
Dim N As Long
 
 
URL = "http://www.google.com/finance?q=" & Currency_Rate
Set REQ = CreateObject("microsoft.xmlhttp")
With REQ
    .Open "POST", URL, False
    .setRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"
    .send
    Txt = .ResponseText
End With
Set REQ = Nothing
 
N = InStr(Txt, "1 " & Currency_Rate)
If N > 0 Then
    TxtRate = Mid(Txt, N)
    TxtRate = Left(TxtRate, InStr(TxtRate, "USD") - 2)
    TxtRate = Mid(TxtRate, InStr(TxtRate, ">") + 1)
    Rate = TxtRate
End If
End Function

PS. On pourrait aussi récupérer la date de cotation (sous forme de texte de type Jun 12, 11:34PM)

15/06/2015, 10h30
ThaHardy

Re

Un grand merci Mercatog,
Comme la derniere fois cela marche parfaitement !

Du coup comment ferais tu pour récupérer la date de cotation? Car par soucis de précision effectivement cela serait mieux (merci de m'y avoir fait penser)

Cordialement

TH
15/06/2015, 10h46
Marc-L

Bonjour,

en utilisant l'outil d'inspection d'un navigateur, la solution évidente est de récupérer le texte de l'ID "price-panel"
contenant la cotation en première ligne et la date en seconde (un p'tit Split) via la méthode du post #5 de Patrick …

Sinon directement dans le code, le B-A-BA est au moins d'y regarder ce que définit la donnée à extraire !
Et ici c'est simple : <span class="nwp"> (là encore avec un Split) …

_____________________________________________________________________________________________________
Je suis Charlie - Je suis Bardo

ThaHardy, j'espère que tu vas t'approprier la méthode pour t'envoler de tes propres ailes.

Regarde la recommandation de Marc-L

Sinon, pour la dernière fois sur le même point (j'ajoute du sel avec un type personnalisé)

Code:

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
Option Compare Database
Option Explicit
 
Private Type Cotation
    Taux As Single
    Dte As String
End Type
 
Private Sub BtnCurrency_Click()
Dim LaValeur As Cotation
Dim SetA As Object
 
Set SetA = CurrentDb.OpenRecordset("TBLCurrency", dbOpenTable)
With SetA
    Do Until .EOF
        LaValeur = Rate(!Currency)
        .Edit
        With LaValeur
            ![CurrencyToDollar] = .Taux
            ![CurrencyRateDate] = .Dte
        End With
        .Update
        .MoveNext
    Loop
    .Close
End With
Set SetA = Nothing
MsgBox "Currency Rates have been updated with success"
End Sub
 
Function Rate(ByVal Currency_Rate As String) As Cotation
Dim URL As String, Txt As String, TxtRate As String, TxtDate As String
Dim REQ As Object
Dim N As Long
 
 
URL = "http://www.google.com/finance?q=" & Currency_Rate
Set REQ = CreateObject("microsoft.xmlhttp")
With REQ
    .Open "POST", URL, False
    .setRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 10.0; Windows NT 6.1; WOW64; Trident/6.0)"
    .send
    Txt = .ResponseText
End With
Set REQ = Nothing
 
N = InStr(Txt, "1 " & Currency_Rate)
If N > 0 Then
    TxtRate = Mid(Txt, N)
    TxtRate = Left(TxtRate, InStr(TxtRate, "USD") - 2)
    TxtRate = Mid(TxtRate, InStr(TxtRate, ">") + 1)
 
    TxtDate = Mid(Txt, InStr(Txt, "<div class=time id="))
    TxtDate = Left(TxtDate, InStr(TxtDate, "GMT") - 2)
    TxtDate = Mid(TxtDate, InStr(TxtDate, ">") + 1)
 
    With Rate
        .Taux = TxtRate
        .Dte = TxtDate
    End With
End If
End Function

PS. attention pour la compatibilité des données, la date de cotation est du texte, il faudra en tenir compte dans ta table TBLCurrency.

15/06/2015, 12h11
ThaHardy

Re

Merci a vous c'est bien sympa de votre part,

J'ai essayé de comprendre commment le premier code marchait pour l'appliqué aux Currencies mais je vous avoue que je suis un nouveau né dans le domaine Access et VBA en général étant donné que je viens de commencé donc je vous avoue que de temps a autres j'ai du mal a saisir tout les nuances des codes que vous me donné mais je fais effectivement mon possible pour m'apporprier les codes mais ce n'est pas toujours évident.

En tout cas merci beaucoup pour votre aide cela marche du feu de dieu ! C'est génial merci a tous et bonne continuation... et peut-etre a la prochaine ;)

Amicalement

TH
15/06/2015, 12h51
Marc-L

Bonjour Mercatog !

Dans le code actuel renvoyé par la requête, je ne trouve pas de <div class=time id= ! (test sur VSAR)

Il y a bien un élément Span avec cette classe mais en référence à un évènement futur du 3 Août …
15/06/2015, 14h53
mercatog

Bonjour Marc-L

L’intéressé à imbriqué 2 sujets en 1, le 2nd fait référence aux devises (EUR, JPY, GBP, CHF ....)
D'où le test de la ligne 49 du code
15/06/2015, 15h05
Marc-L

Merci mercatog !

Le principe est effectivement le même pour une devise …

Voir 40 message(s) de cette discussion en une page