Discussion :

[Eric94360]

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

[unparia]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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.

[Eric94360]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

=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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[patricktoulon]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

"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

[Eric94360]

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

[patricktoulon]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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

[patricktoulon]

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