Discussion :

[taha51201]

Bonjour Tout le monde,
Je veux récupérer une image dans mon userform à partir d'un lien hypertexte(vers une image) dans une feuille de calcul .
Merci d'avance.

[BENNASR]

bonjour taha / la forum
occasion pour souhaiter bonne année à toutes et à tous
ta demande n'est pas claire au moins pour moi
une discussion ci haut à voir peut être va t'aider

https://www.developpez.net/forums/d2...llule-via-vba/

[Tylert]

j'ai tappé dans Google: "récupérer une image dans mon userform à partir d'un lien hypertexte".
Le 3ème lien contenant du code que tu devras adapter, mais qui me semble convenir: Au lieu de coller dans une cellule, il faudra coller l'image dans l'attribut picture de ton userform (et éventuellement changer les attributs Picturealignement, PictureSize... etc...).
Google est ton ami!!

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
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
 
Sub LinkToImage()
    For Each cel In Selection
        cel.Offset(0, 2).Select
        cel.Offset(0, 2).RowHeight = 100
        cel.Offset(0, 2).ColumnWidth = 40
 
        If URLValid(cel.Value) = 0 Or HttpExists(cel.Value) = 0 Then
           cel.Offset(0, 2).Value = "Photo non dispo"
        Else
            Set Image = ActiveSheet.Pictures.Insert(cel.Value)
            With Image
                .ShapeRange.LockAspectRatio = msoTrue
                .Width = cel.Offset(0, 2).Width
                .Height = cel.Offset(0, 2).Height
                .Left = cel.Offset(0, 2).Left
                .Top = cel.Offset(0, 2).Top
            End With
        End If
    Next cel
 
End Sub
 
Function URLValid(url As String) As Boolean
    If InStr(url, "png") > 0 Then
        URLValid = True
    ElseIf InStr(url, "jpg") > 0 Then
        URLValid = True
    ElseIf InStr(url, "jpeg") > 0 Then
        URLValid = True
    ElseIf InStr(url, "bmp") > 0 Then
        URLValid = True
    Else
        URLValid = False
    End If
End Function
 
Function HttpExists(ByVal sURL As String) As Boolean
    Dim oXHTTP As Object
    Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
    On Error GoTo haveError
    oXHTTP.Open "HEAD", sURL, False
    oXHTTP.send
    HttpExists = IIf(oXHTTP.Status = 200, True, False)
    Exit Function
haveError:
    Debug.Print Err.Description
    HttpExists = False
End Function