Stocker dans un répertoire, des images identifiées par un lien hypertexte.

Version imprimable

12/01/2019, 18h11
Eric94360

Stocker dans un répertoire, des images identifiées par un lien hypertexte.

Bonjour,

Je dispose de liens hypertextes, situés les uns au dessous des autres dans une colonne d'un tableau Excel. Ces liens me ramènent chacun à une image se trouvant dans un serveur Intranet.
A l'aide d'une macro VBA, je désire ouvrir les images une par une, leur donner un nom, et les stocker dans un répertoire donné. Certains liens sont inactifs, je dois donc les ignorer.

Merci de votre aide.

Eric
12/01/2019, 20h50
unparia

Bonjour
ceci (exemple) te retournera l'adresse du 1er lien dans la cellule I20

Code:

Range("I20").Hyperlinks(1).Address

Important : le chemin complet de cette adresse ( genre C:\..\toto.jpg") ne sera retourné que si le lien pointe vers un dossier distinct de celui de ton classeur.
Si seul est retourné, par exemple, "toto.jpg", il t'appartient de compléter par le chemin du dossier de ton classeur (ThisWorkbook.Path & "\")

Pour ce qui est du reste -->> ouvre ton aide interne vba à la rubrique FileCopy, instruction et applique cette instruction extrêmement simple.
13/01/2019, 12h43
Eric94360

Copier image obtenue par lien Hypertexte dans un répertoire
Merci uparia pour ta réponse. Mais comme je manque vraiment d'expérience, j'ai besoin de précisions.
Dans le cellule I20 se trouve déjà mon lien Hypertexte, obtenu grâce à une formule regroupant plusieurs cellules :
La voici

Code:

=Lien_Hypertexte("http://ute."&E20&".prd.sie.courrier.intra/V1/"&F20&"/image?format=jpeg")

Dans cette cellule, j'obtiens bien un lien Hypertexte, et lorsque je clique dessus, j'ai bien mon image qui s'ouvre. Je voudrais la stocker dans un répertoire de mon disque dur : C:\visuel

Ce serait facile si je n'avais qu'une seule image. Mais j'en ai tout un tas à placer dans ce répertoire.

Je rentre le code suivant :
Code:

1 2 3 4 5 6 7 8 Sub CopyFichier() Dim SourceFile, DestinationFile SourceFile = Range("G20") DestinationFile = "C:\plis" FileCopy SourceFile, DestinationFile End Sub
Et bien sûr, ça coince sur la ligne FileCopy
13/01/2019, 13h18
patricktoulon

re

bonjour
je suis pas sur que le lien soit exploitable comme tel si E20 et F20 sont des cellules

Code:

"http://ute."&E20&".prd.sie.courrier.intra/V1/"&F20&"/image?format=jpeg"

les "&" doivent etre espacés sinon ils sont pris comme faisant parti de la chaine du lien ainsi que les guillemets internes qui normalement doivent etre doublés sinon bien evidement declenche une erreur

pour tester tu peux simplement reprendre le lien complet et le coller dans la barre d'adresse de ton explorateur pour voir si l'image s'affiche ou si le blob(enregistrer sous) se declenche

ensuite comme c'est un intranet ou meme net je suis pas sur que filecopy soit approprié
je pense plutot que tu devra telecharger l'image
microsoft.xmlhtttp et accompagné de l'object stream
tu trouvera divers exemples sur le forum

pourrait ton avoir un lien valide correspondant a ce lien
13/01/2019, 13h32
Eric94360

1 pièce(s) jointe(s)

Bonjour Patrick,

Je joins un fichier. Mais, tu as raison, comme il s'agit d'un Intranet, le lien, qui fonctionne très bien sur mon ordinateur professionnel, ne fonctionne pas à partir de mon ordi perso.

Eric

re
avec le fichier que tu a donné teste cela
et dit moi si tu a bien tes images sur le bureau dans un dossier "mes images"

et si les images sont valides
et donne moi ce que tu obtiens dans le debug

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub test()
    Dim chemin$, i&
    chemin = Environ("userprofile") & "\DeskTop\mesimages\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Debug.Print ActiveSheet.Cells(i, 7).Value
        récup_imge Cells(i, "G").Value, chemin, i
    Next
End Sub
Function récup_imge(url As String, chemin As String, index As Long) As String
     Dim ReQ As Object, oStream As Object
    'On Error Resume Next    'On ne gère pas les erreurs
    Set ReQ = CreateObject("Microsoft.XMLHTTP")
    ReQ.Open "get", url, False: ReQ.send
    Debug.Print index & "  " & CStr(ReQ.Status)
   if req.status=200 then 
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open: oStream.Type = 1: oStream.Write ReQ.responsebody: oStream.SaveToFile chemin & "image" & index & ".jpg": oStream.Close
   end if
 Set oStream = Nothing: Set ReQ = Nothing
End Function

13/01/2019, 19h36
Eric94360

Bonsoir Patrick,

Merci infiniment pour le temps que tu as passé. La procédure que tu m'as transmise fonctionne parfaitement bien. J'ai juste dû activer la ligne On Error Resume Next qui permet à la macro de ne pas tenir compte des liens qui ne sont plus actifs. J'ai pu télécharger environ 500 images en 1/2 heure, sans que le système plante, ce qui est plus que satisfaisant, car ma liaison Internet est mauvaise.

Bien cordialement
Eric
13/01/2019, 20h06
patricktoulon

re

re
en effet 3.6secondes par image ca fait un peu long
mais bon maintenant tu a une technique parmis d'autres pour recupérer tes images sur ton serveur et les copier sur ton DD
de rien ;)