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