Insérer un image à partir d'un lien url

Bonjour ,

Je ne peux toujours pas insérer d'images à partir de l'URL et mon responsable m'a rapidement demandé d'ajouter 2156 photos

Pour le faire manuellement, il faudrait beaucoup de temple

J'ai vraiment besoin de votre aide

Merci d'avance

Bonjour,

Voici du code qui permet d'importer les images et de les afficher en B

Option Explicit

' ***********************************************************************
' *****                                                             *****
' *****        CODE PierreP56 : http://tatiak.canalblog.com/        *****
' *****                                                             *****
' ***********************************************************************

Sub Affiche_Images()
Dim rep As String, Ndf As String, lg As Integer, i As Integer
Dim Sh As Shape, Di() As String, W As Single

    rep = ThisWorkbook.Path & "\Img\"
    If Not Exist_Rep(rep) Then MkDir rep
    With Sheets(1)
        lg = .Cells(Rows.Count, "A").End(xlUp).Row
        For i = 7 To lg
            Ndf = Ndf_Img(.Cells(i, "A").Value)
            With .Cells(i, "B")
                If Exist_Fichier(rep & Ndf) Then
                    Di = Split(DimensionsImage(rep & Ndf), " x ")
                    W = CSng(Di(0)) / CSng(Di(1)) * .Height
                    Set Sh = Sheets(1).Shapes.AddPicture(rep & Ndf, True, True, _
                        .Left + (.Width / 2) - (.Height / 2), .Top, W, .Height)
                    Sh.Name = "_" & i
                End If
            End With
        Next i
    End With
End Sub

Function Ndf_Img(URL As String) As String
Dim rep As String, Ndf As String, Id As Integer

    Ndf_Img = ""
    If UCase(Right(URL, 4)) = ".JPG" Then
        rep = ThisWorkbook.Path & "\Img\"
        Ndf = Right(URL, InStr(1, StrReverse(URL), "/") - 1)
        If Not Exist_Fichier(rep & Ndf) Then
            Id = DownloadJPG(URL, rep & Ndf)
            If Id >= 0 Then Ndf_Img = Ndf
        Else
            Ndf_Img = Ndf
        End If
    End If
End Function

Function Exist_Rep(Ndf As String) As Boolean
    On Error Resume Next
    Exist_Rep = GetAttr(Ndf) And vbDirectory
End Function

Public Function Exist_Fichier(S As String) As Boolean
Dim tatiak As Object

    Set tatiak = CreateObject("Scripting.FileSystemObject")
    Exist_Fichier = tatiak.FileExists(S)
End Function

' *************************************************************************************************
' Inspiré de => http://arkham46.developpez.com/articles/ofNdfe/ofNdfeweb/?page=page_5
Function DownloadJPG(URL As String, Ndf As String) As Integer
Dim f As Integer, buffer() As Byte

    On Error GoTo errhdlr
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .send
        If .Status = 200 Then
           f = FreeFile
           Open Ndf For Binary As #f
           buffer = .responseBody
           Put #f, , buffer
           Erase buffer
           Close #f
           DownloadJPG = 0
        End If
    End With
    Exit Function

errhdlr:
    DownloadJPG = -1
End Function

' par Excel-Malin.com ( https://excel-malin.com )
' https://excel-malin.com/codes-sources-vba/vba-trouver-hauteur-largeur-image/
Public Function DimensionsImage(Fichier As String) As String
Dim objShell As Object, objDossier As Object, objFichier As Object
Dim ImageDossier As Variant, ImageFichier As Variant, DimensionsI As Variant

    On Error GoTo Erreur

    ImageFichier = Mid(Fichier, InStrRev(Fichier, "\") + 1)
    ImageDossier = Left(Fichier, Len(Fichier) - Len(ImageFichier))

    Set objShell = CreateObject("Shell.Application")
    Set objDossier = objShell.Namespace(ImageDossier)
    Set objFichier = objDossier.ParseName(ImageFichier)

    DimensionsI = CStr(objFichier.ExtendedProperty("Dimensions"))
    DimensionsI = Left(DimensionsI, Len(DimensionsI) - 1)
    DimensionsImage = Right(DimensionsI, Len(DimensionsI) - 1)

    Set objShell = Nothing
    Set objDossier = Nothing
    Set objFichier = Nothing
    Exit Function

Erreur:
    DimensionsImage = ""
End Function

Pierre

merci beaucoup mais le problème importation des images prendre beaucoup de tempe