Code source d'une page sur le net

Version imprimable

bonjour a tous

voila une toute petite fonction qui peut avoir bien des utilités

elle récupère le code source d'une page sur le net au format html ou format texte

voila le code pour la fonction

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
 
Option Explicit
Dim Destination As String  'variable pour le chemin complet du fichier de destination
Dim l_URL As String        ' variable pour le lien de la page html
Dim Lapage_en_HTML         'variable pour l'object "Microsoft.XMLHTTP"( l'object XML)
Dim sourcetext As String  ' varaible pour le texte de sortie au format texte
Dim texte As String        'variable pour le texte a découpé par les ""chr(13)""
Dim i As Long              ' variable pour le decompte des lignes dans le texte de sortie en html ou texte
Public Function GetCodeSource(sURL, Optional au_format_text As Boolean = "false")
    Set Lapage_en_HTML = CreateObject("Microsoft.XMLHTTP")    'instancie l'object
    Lapage_en_HTML.Open "GET", sURL    'ouvre l'url dans l'object
    Lapage_en_HTML.Send
    Do: DoEvents: Loop While Lapage_en_HTML.ReadyState <> 4    'attendre que la page soit chargée
 
    'le code source est dans """"Lapage_en_HTML.ResponseText""""
    'on créé un object "htmlfile"
    With CreateObject("htmlfile")
        'on y ecrit le codesource complet
        .Write Lapage_en_HTML.ResponseText
        'Ici on garde que le texte au format texte( sans les balises)
        sourcetext = .body.innerText
    End With
    'selon si la variable "au_format_text" est a true ou falsele texte de sortie sera en html ou texte
    GetCodeSource = IIf(au_format_text, sourcetext, Lapage_en_HTML.ResponseText)
    sourcetext = ""
End Function

veuillez noter que la variable "au_format_text" dans la fonction est "OPTIONAL" c'est cette variable qui nous servira a déterminer le format de sortie lors de son appel

et voila un exemple d'utilisation :
nous allons enregistrer le code source dans un fichier texte sur le bureau

avec les balises

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Sub test1()
    l_URL = "http://www.programme-tv.net/programme/programme-tnt.html"    'la variable l_URL contient le lien de la page html que l'on veux récupérer
    Destination = "C:\users\" & Application.UserName & "\Desktop\code-source-de-lapage.txt"    'la variable destination contient le chemin complet du fichier de destination
texte = GetCodeSource(l_URL)    'avec les balises(format html)
       Open Destination For Output As #1    'ouverture du nouveau fichier et ecriture de chaque ligne presente dans le texte
    For i = 0 To UBound(Split(texte, Chr(13)))
        Print #1, Split(texte, Chr(13))(i)
    Next
    'fermeture du fichier après écriture
    Close #1
End Sub

ou sans les balise(format texte )

Code:

1
2
3
4
5
6
7
8
9
10
11
12
 
Sub test2()
    l_URL = "http://www.programme-tv.net/programme/programme-tnt.html"    'la variable l_URL contient le lien de la page html que l'on veux récupérer
    Destination = "C:\users\" & Application.UserName & "\Desktop\code-source-de-lapage.txt"    'la variable destination contient le chemin complet du fichier de destination
    texte = GetCodeSource(l_URL, True)    'sans les balises(format texte)
    Open Destination For Output As #1    'ouverture du nouveau fichier et ecriture de chaque ligne presente dans le texte
    For i = 0 To UBound(Split(texte, Chr(13)))
        Print #1, Split(texte, Chr(13))(i)
    Next
    'fermeture du fichier apres ecriture
    Close #1
End Sub

bien sur le lien de la page est a renseigner ici:

Code:

l_URL = "http://www.programme-tv.net/programme/programme-tnt.html"

voila elle fonctionne parfaitement bien et pour une fois le code est propre et commenté:mouarf::mouarf:

qu'en pensez vous ?

11/10/2012, 22h46
mercatog
Bonsoir Patrick

Une question, pourquoi tu as choisi de faire une boucle d'écriture ici
Code:

1 2 3 For i = 0 To UBound(Split(Texte, Chr(13))) Print #1, Split(Texte, Chr(13))(i) Next
Au lieu d'écrire directement

Code:

Print #1, Texte
11/10/2012, 22h53
patricktoulon

re

bonsoir mercatog

figure toi que chez moi ça ne fonctionne pas

c'est toujours le même problème et pas la première fois tu avais fais déjà la remarque

mais en effet pour ce qui ont un office bien installé il peuvent enlever les lignes

cela dit dans cette boucle on peut encore modifier chaque ligne avant qu'elle soit écrite
d'ailleurs c'est comme ça que je l'utilise dans mon cas afin de supprimer tout les mot qui ne me serve pas

au plaisir
12/10/2012, 12h45
mercatog

Bonjour Patrick

Citation:

pas la première fois tu avais fais déjà la remarque

Ne prends pas ma petite remarque comme une remarque pure et simple ;)
Mais dans le sens d'améliorer tes précieuses contributions.

Tu conçois que réfléchir ensemble mieux que de réfléchir en solitaire et cela n'enlève en aucun cas tes mérites.
Tu conçois aussi que tu as fais (selon moi) d'un grand progrès surtout au niveau des déclarations des variables et de l'indentation de tes jolis codes.
12/10/2012, 13h28
patricktoulon

re

bonjour mercatog

non rassure toi je ne prend rien en mal

ce que je voulais dire c'est que dans des anciennes discutions on avait déjà abordé ce souci que j'ai d'avoir certaines fonctions natives vba qui déconne un peu je n'ai plus mon disque office 2007 par contre j'ai toujours ma licence
je n'arrive pas a en telecharger un complet

surtout depuis que j'ai installé visualstudio2008 express une vrai connerie ce machin :mouarf::mouarf:

au plaisir
13/10/2012, 20h10
kiki29

Salut Patou, pour abonder dans le même sens que Mercatog, je constate une meilleure lisibilité du code ainsi qu'une orthographe plus orthodoxe.
13/10/2012, 20h15
patricktoulon

re

bonjour kiki29

je te remercie pour l'appréciation ça fait toujours plaisir

Citation:

lisibilté

:mouarf::mouarf::mouarf: non j'rigole:mouarf:
au plaisir

Bonsoir Patrick,
Très intéressant et pratique ce code !
Pour l'exemple par contre la "destination" me gêne un peu car je suis encore sous XP alos je me suis rappelé d'un bout de code permettant de retrouver les dossiers spéciaux

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 
Option Explicit
Public Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" (ByVal hwndOwner As Long, ByVal lpszPath As String, ByVal nFolder As Long, ByVal fCreate As Long) As Long
 
Public Function SDossier(Dossier As Long, hwnd As Long)
Dim buff As String
buff = Space(260)
SHGetSpecialFolderPath hwnd, buff, Dossier, 0
SDossier = Left(buff, InStr(1, buff, Chr(0)) - 1)
End Function
 
Sub Ou_est_le_bureau()
MsgBox SDossier(0, 0), vbOKOnly, "Chemin du bureau"
End Sub
 
 
Sub Lister_tous_dossiers_speciaux()
Dim i As Long
For i = 0 To 60
Debug.Print i & "=" & SDossier(i, 0)
Next i
End Sub

25/10/2012, 12h23
patricktoulon

re

bonjour oliv-

oui c'est vrai mais la destination n'était qu'un exemple certainement changé pour un autre utilisateur
je n'est donc pas trouvé nécessaire de modifier ce point car avant tout
ce qui est intéressant dans ce code c'est la possibilité de récupérer le code source afin de pouvoir travailler sur les divers éléments en string
plus rapide que la méthode avec l'object "IE"

tu devrais aller voir la seconde contribution a ce sujet sur le "getclassname"

une partie du code est identique il ilustre ce que je viens de dire plus haut

cela dit ton bout de code est intéressant
mais moi j'aurais utilisé la fonction environ sur le 40 par exemple

mais pour d'autre travaux je vais garder ta solution elle me plaît

au plaisir

petite mise ajour (ameliorationn du code )

Bonjour
je vous propose aujourd'hui une petite mise a jour
ayant travailler sur divers demande ces derniers jour sur la récupération d'élément dans une page html pour plusieurs membres

j'ai décidé de mettre au gout du jour ma petite fonction magique

j'utilise maintenant un 3 Emme argument de type booleen pour l'attente du readystate sur l'objet

utilisé normalement avec la méthode "POST" et non pas "GET"

je garde la méthode "GET" car la méthode "POST" génère des erreurs lors du traitement du texte

la boucle do loop a donc disparu

j'ai aussi séparer la transformation en texte normal j'en ai fait une fonction séparée

j'ai ajouté aussi une nouvelle fonction "GetElementBY" qui avec 3 arguments vous récupère un tableau d'élément par balise ou par classe

a mettre en haut de module

Code:

1
2
3
4
5
6
7
8
9
10
11
Option Explicit
'*********************************************************
'constantes pour les arguments de recherches             *
'                                                        *
Public Const classe = "class=""" '                       *
Public Const ID = "id=""" '                              *
Public Const TR = "<tr>" '                               *
Public Const TD = "<td>" '                               *
'                                                        *
' Vous pouvez ajouter des constante pour les Balises ICI *                                                 *
' ********************************************************

voila la fonction de récupération du code source

Code:

1
2
3
4
5
6
7
8
9
 
Public Function GetCodeSource(sURL, Optional au_format_text As Boolean = "false")
    Dim Lapage_en_HTML As Object
    Set Lapage_en_HTML = CreateObject("Microsoft.XMLHTTP")    'instancie l'object
    Lapage_en_HTML.Open "GET", sURL, False   'ouvre l'url dans l'object
    Lapage_en_HTML.Send ' envoie la requette
    'selon si la variable "au_format_text" est a true ou falsele texte de sortie sera en html ou texte
    GetCodeSource = IIf(au_format_text, Html_to_text(Lapage_en_HTML.ResponseText), Lapage_en_HTML.ResponseText)
End Function

voila la fonction de transformation du code source en texte normal

Code:

1
2
3
4
5
6
7
8
9
10
 
Public Function Html_to_text(codesource)
    'on créé un objet html
    With CreateObject("htmlfile")
        'on y ecrit le codesource complet
        .Write codesource
        'Ici on garde que le texte au format texte( sans les balises)
        Html_to_text = .body.innerText
    End With
End Function

voila les deux test avec ou sans balises

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Sub test_avec_balise()
    Dim text, l_URL As String
    l_URL = "http://www.developpez.net/forums/f664/logiciels/microsoft-office/excel/macros-vba-excel/"
    text = GetCodeSource(l_URL, False) ' le 3 eme argument est facultatif ,il est a false dans ce cas
    MsgBox text
 
End Sub
 
Sub test_sans_balise()
    Dim text, l_URL As String
    l_URL = "http://www.developpez.net/forums/f664/logiciels/microsoft-office/excel/macros-vba-excel/"
    text = GetCodeSource(l_URL, True)
    MsgBox text
End Sub

voila maintenant la nouvelle fonction de recherche par elements de type (classe,tr,td,id) on peut bien sur en ajouter ou le marquer en dur dans l'appel a la fonction

Code:

1
2
3
4
5
6
 
Public Function GetElementBY(lien As Variant, letype, Optional nom As String="") As Variant
    Dim text
    text = GetCodeSource(lien)
    GetElementBY = Split(text, letype & nom)
End Function

et voici un exemple d'appel a cette fonction

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
Sub test_le_GetElementBY()
    Dim l_URL As String, elements
    l_URL = "http://www.developpez.net/forums/f664/logiciels/microsoft-office/excel/macros-vba-excel/"
   'exemple 1
'on recherche par la classe  "threadbit new"
'elements = GetElementBY(URL de la page , type d'element , "nom de l'element ")
elements = GetElementBY(l_URL, classe, "threadbit new")
 
'exemple 2
'on rcherche les element pas le type de balise en l'occurrence ici les balises "<tr>"
'elements = GetElementBY(URL de la page , type d'element )
elements = GetElementBY(l_URL, TR)
 
    MsgBox " Voici la dernière question qui a été traitée" & vbcrlf & Html_to_text(elements(1))
End Sub

Voila ce petit module représente une alternative intéressante au niveau de l'efficacité par rapport a l'objet IE en terme d'attente et de temps de travail

qu'en pensez vous ??

16/02/2014, 17h34
patricktoulon

petite amelioration pour le cache

Bonjour
Effectivement la méthode "GET" a tendance a aller récupérer la page dans le cache et non pas sur le net après la 1 ère fois

changer une ligne dans la fonction semble rectifier le probleme

Code:

Lapage_en_HTML.Open "GET", sURL & "?nocache= + Math.random()", False 'ouvre l'url dans l'Object

voila voila
Au plaisir

Amelioration et ajout d'option

Bonjour a tous

aujourdh'ui en recherchant dans mes archives j'ai retrouver des petites chose intéressantes

je vais donc vous montrer comment récupérer un table ou un élément particulier sans passer par le traitement du code en string mais directement en objet ici en l'occurrence (table)

en effet la fonction html_to_text restitue le ".innertext " de l'intégralité ou un fragment du code source

je vous propose alors une nouvelle fonction "html_to_outerhtml" qui est Kazi identique a l'autre sauf qu'elle garde la mise en forme du code ce qui va bien nous arranger pour récupérer une table par exemple
tout dabord le haut de module
je vous rappelle que des constantes peuvent etre facilement ajoutées
Code:

1 2 3 4 5 6 7 8 9 10 11 '********************************************************* 'constantes pour les arguments de recherches * ' * Public Const classe = "class=""" ' * Public Const ID = "id=""" ' * Public Const TR = "<tr>" ' * Public Const TD = "<td>" ' * Public Const TAble = "<table" ' * ' * ' Vous pouvez ajouter des constante pour les Balises ICI * ' ********************************************************
voila cette fonction
Code:

1 2 3 4 5 6 7 8 9 10 Public Function Html_to_outerhtml(codesource) 'on créé un objet html With CreateObject("htmlfile") 'on y ecrit le codesource complet .Write codesource 'Ici on garde que le texte au format outerhtml qui garde en memoire la mise en forme(pratique pour les tables) Html_to_outerhtml = .body.outerhtml 'la fonction devient l'element mis en forme End With End Function
comme vous pouvez le constater ca n'est que la derniere ligne qui change par rapport a l'autre

j'ai aussi ameliorer la fonction get elementBY
en effet dans certaines le balisage ainsi que la nomination par ID ,classe,name peuve etre un peu différente

donc la voici
Code:

1 2 3 4 5 6 Public Function GetElementBY(lien As Variant, Optional balise As String = "", Optional letype As String = "", Optional nom As String = "") As Variant Dim code code = GetCodeSource(lien) 'recuperation du codesource complet de la page avec l'apel a la fonction getcodesource GetElementBY = Split(code, balise & letype & nom) 'decoupage du codesource par les arguments balise et type et nom du type End Function
essayons maintenant de récupérer la table sur une page financiere najaQ Quote
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Sub test_de_recuptable() Columns("A:F") = "" [A2].Select Dim l_URL As String, elements, mydata, fich, pag, code 'les variables utiles l_URL = "http://www.nasdaq.com/symbol/f/historical" 'declaration de l'url [A1] = l_URL element = GetElementBY(l_URL, TAble)(3) 'recuperation de l'element Set mydata = New DataObject 'instentiation du nouvel object code = TAble & Html_to_outerhtml(Split(element, "</table>")(0)) & "</table>" 'reconstitution du code de l'élément mydata.SetText code 'inscription du codesource de l'element reconstitué dans l'object mydata.PutInClipboard 'mise en pressepapier Sheets(3).Paste 'collage du tableau final dans le sheets End Sub
comme vous pouvez le constater je ne me sert plus de multi split pour récupérer chaque cell de la table mais d'un dataobject contenant le code source de la table et rien que la table par une variable appelée code
je le calque directement sur le sheet par un .paste

essayons maintenant de recupérer la derniere question qui a été posée sur le forum vba et exel
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Sub test_recup_last_question_vba_sur_DVP() [A2].Select Dim l_URL As String, elements, mydata, fich, pag l_URL = "http://www.developpez.net/forums/f664/logiciels/microsoft-office/excel/macros-vba-excel/" elements = GetElementBY(l_URL, "<h3 ", classe, "threadtitle") Set mydata = New DataObject mydata.SetText Html_to_outerhtml(elements(2)) mydata.PutInClipboard 'le code du tableau est copié dans le presse-papiers Set fich = ThisWorkbook Set pag = fich.Sheets(3) pag.Paste End Sub
je vous laisse les découvrir

qu'en pensez vous ?