XL 2016 Recherche d'url valides

azraelle à dit:

Bonjour à tous, c'est mon premier post dans ce forum. Je ne suis pas débutante sur Excel, mais je ne suis pas experte non plus. J'utilise des macros régulièrement pour automatiser des tâches dans mon boulot, mais là je sèche.
J'ai un fichier avec une seule colonne qui comprend des URL.
Mon souci : avoir dans la deuxième colonne OK si l'URL est valide, et NOK si elle ne l'est pas.
Merci d'avance pour l'aide que vous pourrez m'apporter, bonne soirée 🙂

Cliquez pour agrandir...

jurassic pork à dit:

Hello,
qu'entends-tu par url valide ? une url dont la syntaxe est correcte (ex : https://monsite.com) ou une url qui est "vivante" c'est à dire qui répond à un ping ou qui affiche quelque chose ou qui répond à une requête http ? Sinon donne-nous un exemple d'url non valide.
Ami calmant, J.P

Cliquez pour agrandir...

azraelle à dit:

Effectivement, j'aurais dû préciser... 🙂
Dans ma liste il y a pas mal d'URL qui ne mènent nulle part (error 404 par exemple). Je recherche les URL qui répondent à un pign, et encore mieux (mais je sais que c'est encore plus compliqué) une URL qui renvoie vers une image. Je posterai un exemple seulement mardi (je ne bosse pas avant et n'ai pas mon fichier sous la main) 🙁

Cliquez pour agrandir...

jurassic pork à dit:

OK mais 160000 lignes ça risque d'être très long à tester surtout qu'une erreur 404 peut apparaître après un temps assez important. Si ce n'est pas indiscret à quoi va servir cela ?

Cliquez pour agrandir...

azraelle à dit:

Je travaille en bibliothèque et notre logiciel permet d'avoir accès au catalogue de tous les documents que nous avons. Il permet aussi d'afficher les jaquettes de nos documents, ce qui rend la recherche plus aisée et agréable pour les usagers. Mais certaines jaquettes (URL) sont parfois obsolètes. J'extrais donc la liste une à deux fois par an pour essayer de vérifier les jaquette "périmées" afin de les remplacer.

Cliquez pour agrandir...

jurassic pork à dit:

Ok ben je pense qu'avec ton classeur exemple , on comprend bien ce que tu recherches , il va bien y avoir quelqu'un ici qui va te proposer quelque chose. Le balayage de toutes les url risque de durer plusieurs heures voir plusieurs jours.

Cliquez pour agrandir...

azraelle à dit:

Je peux scinder mon tableau, et j'ai plusieurs "familles" d'URL (pas mal de domaines identiques par exemple que je peux regrouper)

Cliquez pour agrandir...

jurassic pork à dit:

Hello,
voilà ce que je te propose :
1 - on définit une plage nommée Urls qui représente la plage des Urls qu'on veut tester.
2 - Dans la macro
1 - Pour toutes les cellules qui se trouvent dans la plage nommée
1 - On extrait le nom de l'image (NomImg) à l'aide des expressions régulières
2 - On lance une requête http sur l'Url
3 - Si le résultat de la requête est 200 c'est qu'elle a réussit alors on sauvegarde le fichier dans le répertoire dlPath
4 - Si la requête a réussit on écrit aussi OK dans la colonne qui correspond et dans la colonne Nom image sauvegardée on écrit le nom de l'image
5 - Si la requêté échoue , on met NOK dans la colonne qui correspond et on met dans la colonne code Erreur, le code Erreur de la requête

Le code VBA :

VB:

Sub DownloadImages()
Dim cell, dlPath$, NomImg$, imgSrc$
Dim WinHttpReq As Object, oStream As Object, RegEx As Object, Matches As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
Set oStream = CreateObject("ADODB.Stream")
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Pattern = "[^/\\]+$" ' Motif pour extraire nom d'image dans URL
dlPath = "D:\tmp\dlImages\"
For Each cell In Sheets("Feuil1").Range("Urls")
    imgSrc = cell
    Set Matches = RegEx.Execute(imgSrc)
    If Matches.Count = 1 Then
       NomImg = Matches(0)
    Else
       Cells.Offset(0, 3) = "Nom d'image incorrect"
       GoTo NextIteration
    End If
    WinHttpReq.Open "GET", imgSrc, False
    WinHttpReq.send
    Debug.Print imgSrc, WinHttpReq.Status
    If WinHttpReq.Status = 200 Then
       oStream.Open
       oStream.Type = 1
       oStream.Write WinHttpReq.responseBody
       oStream.SaveToFile dlPath & NomImg, 2 ' 1 = no overwrite, 2 = overwrite
       oStream.Close
       cell.Offset(0, 1) = "OK"
       cell.Offset(0, 3) = NomImg
    Else
       cell.Offset(0, 1) = "NOK"
       cell.Offset(0, 2) = WinHttpReq.Status
    End If
NextIteration:
Next cell
Set WinHttpReq = Nothing: Set oStream = Nothing: Set Matches = Nothing: Set RegEx = Nothing
MsgBox "Vérification terminée !"
End Sub

Regarde la pièce jointe 1212256

En pièce jointe le classeur correspondant

Ami calmant, J.P

Cliquez pour agrandir...

jurassic pork à dit:

Hello,
voilà ce que je te propose :
1 - on définit une plage nommée Urls qui représente la plage des Urls qu'on veut tester.
2 - Dans la macro
1 - Pour toutes les cellules qui se trouvent dans la plage nommée
1 - On extrait le nom de l'image (NomImg) à l'aide des expressions régulières
2 - On lance une requête http sur l'Url
3 - Si le résultat de la requête est 200 c'est qu'elle a réussit alors on sauvegarde le fichier dans le répertoire dlPath
4 - Si la requête a réussit on écrit aussi OK dans la colonne qui correspond et dans la colonne Nom image sauvegardée on écrit le nom de l'image
5 - Si la requêté échoue , on met NOK dans la colonne qui correspond et on met dans la colonne code Erreur, le code Erreur de la requête

Le code VBA :

VB:

Sub DownloadImages()
Dim cell, dlPath$, NomImg$, imgSrc$
Dim WinHttpReq As Object, oStream As Object, RegEx As Object, Matches As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
Set oStream = CreateObject("ADODB.Stream")
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Pattern = "[^/\\]+$" ' Motif pour extraire nom d'image dans URL
dlPath = "D:\tmp\dlImages\"
For Each cell In Sheets("Feuil1").Range("Urls")
    imgSrc = cell
    Set Matches = RegEx.Execute(imgSrc)
    If Matches.Count = 1 Then
       NomImg = Matches(0)
    Else
       Cells.Offset(0, 3) = "Nom d'image incorrect"
       GoTo NextIteration
    End If
    WinHttpReq.Open "GET", imgSrc, False
    WinHttpReq.send
    Debug.Print imgSrc, WinHttpReq.Status
    If WinHttpReq.Status = 200 Then
       oStream.Open
       oStream.Type = 1
       oStream.Write WinHttpReq.responseBody
       oStream.SaveToFile dlPath & NomImg, 2 ' 1 = no overwrite, 2 = overwrite
       oStream.Close
       cell.Offset(0, 1) = "OK"
       cell.Offset(0, 3) = NomImg
    Else
       cell.Offset(0, 1) = "NOK"
       cell.Offset(0, 2) = WinHttpReq.Status
    End If
NextIteration:
Next cell
Set WinHttpReq = Nothing: Set oStream = Nothing: Set Matches = Nothing: Set RegEx = Nothing
MsgBox "Vérification terminée !"
End Sub

Regarde la pièce jointe 1212256

En pièce jointe le classeur correspondant

Ami calmant, J.P

Cliquez pour agrandir...

🤔​

azraelle à dit:

Mais ça doit être juste une case à cocher quelque part ça...

​

Cliquez pour agrandir...

dlPath = "D:\tmp\dlImages\"

jurassic pork à dit:

C'est certainement que dans la macro tu n'as pas changé le chemin où l'on écrit les fichiers avec un chemin valide sur ton ordinateur (le chemin doit déjà exister) :

VB:

dlPath = "D:\tmp\dlImages\"

Cliquez pour agrandir...

azraelle à dit:

Ah bah voilà, j'avais pas tout lu... J'ai bien créé un répertoir et mis le bon nom dans la macro :

Regarde la pièce jointe 1212265
Mais il doit y avoir la même subtilité pour NomImg ? (que je n'ai pas vue ou pas comprise...)

Cliquez pour agrandir...

dlPath = "C:\tmp\dlImages\"

jurassic pork à dit:

Le souci c'est ton SaveTofile il faut que tu laisses ce que j'ai mis et que tu change le dlPath comme ceci :

VB:

dlPath = "C:\tmp\dlImages\"

et dans ton répertoire c:\tmp il doit y avoir un répertoire dlImages qui existe où sinon le créer

Cliquez pour agrandir...