rapatrier le code source html en VBA

Anonyme

Bonjour

Cette routine fonctionnait correctement sous XP et depuis que je suis sous W8.1 elle ne fonctionne plus. J'ai déjà posé cette question il y a quelque temps, si il y a du nouveau à ce propos; bien aimable de me tenir au courant. Merci

Sub CherchecodeSource()

Dim CodeSource As String, IE As Object

Dim TempFile As String

On Error Resume Next

Feuil10.[A:A].ClearContents

Set IE = CreateObject("InternetExplorer.application")

TempFile = "c:\Fred.txt"

IE.Visible = False ' Ou True

IE.navigate URL:="http://www.tierce-magazine.com/accueil/pid107-les-reunions-du-jour.html?day=tomorrow"

Do Until IE.ReadyState = 4

DoEvents ' soit la boucle ne sort pas, soit elle sort et "Laligne" est vide dans la boucle suivante

Loop

CodeSource = IE.document.body.innerHTML

Open TempFile For Output As #1

Print #1, CodeSource

Close #1

Open TempFile For Input As #1

Do While Not EOF(1)

Input #1, LaLigne

a = a + 1

Feuil10.Range("A" & a) = LaLigne

If a > 20 And Application.CountA([IDcours!A:A]) = 0 Then

Exit Do

End If

Loop

Close #1

Kill TempFile

IE.Quit

Set IE = Nothing

End Sub

Question verrouillée. Cette question a été migrée à partir de la Communauté Support Microsoft. Vous pouvez voter pour indiquer si elle est utile, mais vous ne pouvez pas ajouter de commentaires ou de réponses ni suivre la question.

0 commentaires

Réponse acceptée par l’auteur de la question

Anonyme

Bonjour

Comme je l'ai indiqué le code tourne avec Office 2010 et IE11/w7.

Par contre on récupère du texte html et non les valeurs qui vous intéressent.

Je ne peux pas aller plus loin n'ayant plus ni IE8, ni Excel 2007.

0 commentaires

22 réponses supplémentaires

Anonyme

2015-11-01T23:24:29+00:00
Bonjour Daniel

Tabl = Split(CodeSource, ""), l'anti schlash est la cle de la réussite.
- quelques lignes supplémentaires pour trouver tous les codes pouvant se situer sur une seul ligne.
Sub CherchecodeSource()

b="www.tierce-magazine.com/accueil/pid107-les-reunions-du-jour.html?day=tomorrow"

   Dim CodeSource As String

    Dim Ligne As Long

    Dim Tabl

    On Error Resume Next

    Feuil10.[A:A].ClearContents

    Feuil10.Select

    If [Feuil10!B1] < Date + 1 Then

'§§§§§§ déplacement des anciens codes vers la droite

        [H:H].ClearContents

        Lad = [B20:H300000].Find("*", , , 2, 1, 2).Row

        Range("B1:G" & Lad).Copy

        Range("C1").Select

        ActiveSheet.Paste

        Feuil10.[B:B].ClearContents

'§§§§§§

        CodeSource = ExtraireSourceHTML(b)

        Tabl = Split(CodeSource, "")

        For Each Item In Tabl

            If InStr(Item, "race_id=") > 0 Then

                Deb = 1

                Ligne = 1

                While InStr(Deb, Item, "race_id=") > 0

                    Ligne = Ligne + 1

                    Feuil10.Cells(Ligne, 2) = Mid(Item, InStr(Deb, Item, "race_id=") + 8, 6)

                    Deb = InStr(Deb, Item, "race_id=") + 9

                Wend

            End If

        Next Item

            [B1] = Date + 1

    End If

End Sub

Public Function ExtraireSourceHTML(LienURL As String)

    With CreateObject("MSXML2.XMLHTTP")

        .Open "GET", LienURL, False

        .send

        If .ReadyState = 4 Then

            If .Status <> 200 Then

                ExtraireSourceHTML = CVErr(xlErrNA)

            Else

                ExtraireSourceHTML = .responseText

            End If

        Else

            ExtraireSourceHTML = CVErr(xlErrNA)

        End If

    End With

End Function
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire
Anonyme

2015-11-02T09:27:47+00:00

Bonjour,

Merci du retour.

Daniel
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire