XL 2016 Recherche d'url valides

azraelle à dit:

J'ai une dernière question, comment puis-je adapter cette macro à un fichier plus long (disons qu'il y ait 100 URL) ?

Cliquez pour agrandir...

jurassic pork à dit:

Dans le gestionnaire de Noms (Formules/Gestionnaire de Noms) il faut que tu changes la dernière ligne à utiliser dans la plage nommée Urls :
Regarde la pièce jointe 1212269
cliquer sur le bouton v (vert) pour valider

Cliquez pour agrandir...

jurassic pork à dit:

Hello,
la première erreur c'est parce que tu as ?v901 à la fin de ton url. La deuxième je ne sais pas .
J'ai changé le code . L'objet qui est utilisé pour les requêtes est plus élaboré . Si le nom d'image se termine par ?xxxx je supprime cette partie. Quand il y a une erreur je ne bloque pas je passe à l'image suivante (il n'y ni OK ni NOK sur la ligne)

VB:

Sub DownloadImages()
Dim myURL As String
Dim cell, dlPath$, NomImg$, imgSrc$, splitter
Dim WinHttpReq As Object, oStream As Object, RegEx As Object, Matches As Object
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
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
       splitter = Split(Matches(0), "?")
       NomImg = splitter(0)
       Debug.Print NomImg
    Else
       Cells.Offset(0, 3) = "Nom d'image incorrect"
       GoTo NextIteration
    End If
    On Error GoTo NextIteration
    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

Ne pas oublier de changer le dlPath dans le code 😉

Ami calmant, J.P

Cliquez pour agrandir...

azraelle à dit:

Malgré quelques erreurs qui restent (ex : http://www.cvs-mediatheques.com/ws/wsgetimg.php?N=a0EQ2652&C=2898&D=1003456&A=37645&W=100&F=0) ça fonctionne super bien ! Un grand merci 🙂

Cliquez pour agrandir...