Copie pages web

Bonjour le forum,

Je cherche à créer une macro permettant de récupérer des pages web par lots et de manière automatique.

Je passe par les fonctions For num et Set fich.

Les pages du site se terminent par un « / », une lettre, un numéro, un (-) et une suite de caractères alphabétiques variables :

https://www.nom du site/X1-abcdefg…

Et ainsi :

For num = 0 To 10
Set fich = Workbooks.Open("http://nom du site/X=" & num)

Mais les pages ne s’ouvrent pas. Est-ce la suite de caractère qui pose problème ?

Quelqu’un a une idée ?

Merci pour votre aide.

Bonjour,

les URL n'admettent pas des espaces, il faut remplacer par %20

peux-tu donner plus d'informations sur ces URL ?

Slt Steelson,

Il n'y a effectivement pas d'espaces dans les URL.

De manière plus précise :

https://www.nomdusite.fr/fr/2018-01-01/X1-fort-de france
https://www.nomdusite.fr/fr/2018-01-01/X2-vaulx-en-velin
https://www.nomdusite.fr/fr/2018-01-01/X3-pas-de-calais...

Les numéros de X pouvant aller jusqu'à 12 pour une même journée.

Sub Macro()

For num = 1 To 12
Set fich = Workbooks.Open("https://www.nomdusite.fr/fr/2018-01-01/X" & num)
Set ongl = ThisWorkbook.Sheets.Add '
ongl.Name = "onglet" & num 
fich.Sheets(1).Cells.Copy 
Workbooks(ThisWorkbook.Name).Activate
    ongl.Select
    Application.DisplayAlerts = False
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
    fich.Close (False) 
    Application.DisplayAlerts = True
Next num 

End Sub

ajoute une fonction URLEncode comme celle-ci :

Function UTF8_URL_Encode(ByVal sStr As String)
    Dim i As Long
    Dim a As Long
    Dim res As String
    Dim code As String

    res = ""
    For i = 1 To Len(sStr)
        a = AscW(Mid(sStr, i, 1))
        If a < 128 Then
            code = Mid(sStr, i, 1)
        ElseIf ((a > 127) And (a < 2048)) Then
            code = URLEncodeByte(((a \ 64) Or 192))
            code = code & URLEncodeByte(((a And 63) Or 128))
        Else
            code = URLEncodeByte(((a \ 144) Or 234))
            code = code & URLEncodeByte((((a \ 64) And 63) Or 128))
            code = code & URLEncodeByte(((a And 63) Or 128))
        End If
        res = res & code
    Next i
    UTF8_URL_Encode = res
End Function

Private Function URLEncodeByte(val As Integer) As String
    Dim res As String
    res = "%" & Right("0" & Hex(val), 2)
    URLEncodeByte = res
End Function

Il en existe d'autres sur la toile !

ou en utilisant js

pas testée pour ma part

Public Function encodeURL(str As String)
    Dim ScriptEngine As Object
    Dim encoded As String

    Set ScriptEngine = CreateObject("scriptcontrol")
    ScriptEngine.Language = "JScript"

    encoded = ScriptEngine.Run("encodeURIComponent", str)

    encodeURL = encoded
End Function

dernière variante (plus simple à comprendre) :

variante supprimée (non fonctionnelle)

Oupssssssss,

Merci pour toutes ces fonctions que je découvre mais qui dépassent largement le cadre de mes acquis actuels.

Je les conserve donc pour y revenir au fur et à mesure de mon évolution.

Et pour revenir sur la problématique de départ, dois-je comprendre qu'il faut en copier une au choix et l'intégrer dans ma macro telle qu'elle est actuellement écrite ?

Avant ou après mon For Num/Next Num ? Je suppose avant ?

Dans les fonctions que tu me proposes gentillement je ne vois pas apparaître l'URL de base. Est-ce à dire que les fonctions vont la détecter automatiquement ?

Enfin et toujours dans les fonctions que tu me proposes, je ne vois pas apparaître le "X" de l'URL qui précède le chiffre qui va déterminer la page exacte à copier et pouvant aller, pour une même journée, par exemple :

de

"nomdusite.fr/fr/2018-01-01/X1-fort-de france"

à

"nomdusite.fr/fr/2018-01-01/X12-mont-st-michel"

J'essaie de comprendre.

Un grand merci d'avance pour tes réponses très attendues, lol

Yeppppppppppp,

J'ai modifié en conséquence et il m'envoie immédiatement le message suivant :

Erreur d'exécution 1104

Désolé... Nous ne trouvons pas

(l'adresse en question)

Peut-être l'avez-vous déplacé, renommé ou supprimé

Et en débogage il surligne en jaune la ligne :

Set fich = Workbooks.Open(EncodeURL("https://www.nomdusite.fr/fr/2018-01-01/X" & num))

Aurais-je fais une erreur ?

La commande que j'ai utilisé, dans l'ordre, est la suivante :

Public Function EncodeURL(url As String) As String
  Dim buffer As String, i As Long, c As Long, n As Long
  buffer = String$(Len(url) * 12, "%")

  For i = 1 To Len(url)
    c = AscW(Mid$(url, i, 1)) And 65535

    Select Case c
      Case 48 To 57, 65 To 90, 97 To 122, 45, 46, 95  ' Unescaped 0-9A-Za-z-._ '
        n = n + 1
        Mid$(buffer, n) = ChrW(c)
      Case Is <= 127            ' Escaped UTF-8 1 bytes U+0000 to U+007F '
        n = n + 3
        Mid$(buffer, n - 1) = Right$(Hex$(256 + c), 2)
      Case Is <= 2047           ' Escaped UTF-8 2 bytes U+0080 to U+07FF '
        n = n + 6
        Mid$(buffer, n - 4) = Hex$(192 + (c \ 64))
        Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
      Case 55296 To 57343       ' Escaped UTF-8 4 bytes U+010000 to U+10FFFF '
        i = i + 1
        c = 65536 + (c Mod 1024) * 1024 + (AscW(Mid$(url, i, 1)) And 1023)
        n = n + 12
        Mid$(buffer, n - 10) = Hex$(240 + (c \ 262144))
        Mid$(buffer, n - 7) = Hex$(128 + ((c \ 4096) Mod 64))
        Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
        Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
      Case Else                 ' Escaped UTF-8 3 bytes U+0800 to U+FFFF '
        n = n + 9
        Mid$(buffer, n - 7) = Hex$(224 + (c \ 4096))
        Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
        Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
    End Select
  Next

  EncodeURL = Left$(buffer, n)
End Function

Sub Macro1()

For num = 1 To 12 
Set fich = Workbooks.Open(EncodeURL("https://www.nomdusite.fr/fr/2018-01-01/X" & num))
Set ongl = ThisWorkbook.Sheets.Add 
ongl.Name = "onglet" & num 
fich.Sheets(1).Cells.Copy 
Workbooks(ThisWorkbook.Name).Activate
    ongl.Select
    Application.DisplayAlerts = False 
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
    fich.Close (False) 
    Application.DisplayAlerts = True 
Next num 
End Sub

en effet la fonction ne marche pas (du reste ce n'est pas celle que j'utilise)

ceci fonctionne :

Sub test()

Set fich = Workbooks.Open(UTF8_URL_Encode("https://forum.excel-pratique.com/viewtopic.php?p=683192#p683192"))

End Sub

Function UTF8_URL_Encode(ByVal sStr As String)
    Dim i As Long
    Dim a As Long
    Dim res As String
    Dim code As String

    res = ""
    For i = 1 To Len(sStr)
        a = AscW(Mid(sStr, i, 1))
        If a < 128 Then
            code = Mid(sStr, i, 1)
        ElseIf ((a > 127) And (a < 2048)) Then
            code = URLEncodeByte(((a \ 64) Or 192))
            code = code & URLEncodeByte(((a And 63) Or 128))
        Else
            code = URLEncodeByte(((a \ 144) Or 234))
            code = code & URLEncodeByte((((a \ 64) And 63) Or 128))
            code = code & URLEncodeByte(((a And 63) Or 128))
        End If
        res = res & code
    Next i
    UTF8_URL_Encode = res
End Function

Private Function URLEncodeByte(val As Integer) As String
    Dim res As String
    res = "%" & Right("0" & Hex(val), 2)
    URLEncodeByte = res
End Function
Rechercher des sujets similaires à "copie pages web"