XL 2016 récupérer une image depuis un SharePoint et la coller dans une cellule

[romss1982]

Bonjour à tous,

je vous explique rapidement mon problème d'autant que je ne maitrise absolument pas les macros.

j'ai un fichier avec pour chaque cellule de la colonne "A" des URL d'un SharePoint qui mène à une photo, j'aimerais avec une macro que la photo (issue de cet URL) puisse être coller en cellule B pour chacune d'entre elle.

j'espère avoir été précis 😉


merci d'avance à tous pour votre aide

 

[Nain porte quoi]

Hello,

ça devrait ressembler à ça, mais je ne peux pas tester car je n'ai pas sharepoint ; j'ai testé avec des adresses en local
Attention, commencez par mettre une dimension "suffisante" à la colonne B et aux lignes. Les images sont ajustées à la plus grande hauteur ou largeur en gardant le ratio

Sub Recup_Images_SharePoint()

    Dim Feuille As Worksheet
    Dim Der_Ligne As Long, i As Long
    Dim URL_SharePoint As String
    Dim Image As Shape
    Dim Cell_Desti As Range
    
    Set Feuille = ThisWorkbook.ActiveSheet
    
    ' Supprime les anciennes images de la colonne B
    For Each Image In Feuille.Shapes
        If Not Intersect(Image.TopLeftCell, Feuille.Columns("B")) Is Nothing Then
            Image.Delete
        End If
    Next Image

    Der_Ligne = Feuille.Cells(Feuille.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To Der_Ligne
        URL_SharePoint = Feuille.Cells(i, 1).Value
        Set Cell_Desti = Feuille.Cells(i, 2)

        If URL_SharePoint <> "" Then
            With Feuille.Shapes
                Set Image = .AddPicture(Filename:=URL_SharePoint, _
                            LinkToFile:=False, _
                            SaveWithDocument:=True, _
                            Left:=Cell_Desti.Left + 2, _
                            Top:=Cell_Desti.Top + 2, _
                            Width:=-1, _
                            Height:=-1)
            End With
            
            ' Ajustement de l'image à la taille de la cellule
            With Image
                .LockAspectRatio = msoTrue
                .Width = Cell_Desti.Width - 4
                If .Height > Cell_Desti.Height Then
                    .Height = Cell_Desti.Height - 4
                End If
                ' centrage
                .Left = Cell_Desti.Left + (Cell_Desti.Width - .Width) / 2
                .Top = Cell_Desti.Top + (Cell_Desti.Height - .Height) / 2
            End With
        End If
        Set Image = Nothing
    Next i

    MsgBox "C'est fait (...ou pas)"
    
End Sub

 

[Nain porte quoi]

Re,

une version 2 amélioré

 

[job75]

Bonjour romss1982, Nain porte quoi, le forum,

Il serait utile d'avoir un exemple d'URL stockée en colonne A.

Récupérer une image stockée sur SharePoint est souvent problématique.

Peut-être est-il plus simple d'ouvrir le fichier image en mettant en B2 la formule =LIEN_HYPERTEXTE(A2;A2)

C'est sans aucune garantie.

A+

 

[halecs93]

Hello,

ça devrait ressembler à ça, mais je ne peux pas tester car je n'ai pas sharepoint ; j'ai testé avec des adresses en local
Attention, commencez par mettre une dimension "suffisante" à la colonne B et aux lignes. Les images sont ajustées à la plus grande hauteur ou largeur en gardant le ratio

Sub Recup_Images_SharePoint()

    Dim Feuille As Worksheet
    Dim Der_Ligne As Long, i As Long
    Dim URL_SharePoint As String
    Dim Image As Shape
    Dim Cell_Desti As Range
   
    Set Feuille = ThisWorkbook.ActiveSheet
   
    ' Supprime les anciennes images de la colonne B
    For Each Image In Feuille.Shapes
        If Not Intersect(Image.TopLeftCell, Feuille.Columns("B")) Is Nothing Then
            Image.Delete
        End If
    Next Image

    Der_Ligne = Feuille.Cells(Feuille.Rows.Count, "A").End(xlUp).Row
   
    For i = 2 To Der_Ligne
        URL_SharePoint = Feuille.Cells(i, 1).Value
        Set Cell_Desti = Feuille.Cells(i, 2)

        If URL_SharePoint <> "" Then
            With Feuille.Shapes
                Set Image = .AddPicture(Filename:=URL_SharePoint, _
                            LinkToFile:=False, _
                            SaveWithDocument:=True, _
                            Left:=Cell_Desti.Left + 2, _
                            Top:=Cell_Desti.Top + 2, _
                            Width:=-1, _
                            Height:=-1)
            End With
           
            ' Ajustement de l'image à la taille de la cellule
            With Image
                .LockAspectRatio = msoTrue
                .Width = Cell_Desti.Width - 4
                If .Height > Cell_Desti.Height Then
                    .Height = Cell_Desti.Height - 4
                End If
                ' centrage
                .Left = Cell_Desti.Left + (Cell_Desti.Width - .Width) / 2
                .Top = Cell_Desti.Top + (Cell_Desti.Height - .Height) / 2
            End With
        End If
        Set Image = Nothing
    Next i

    MsgBox "C'est fait (...ou pas)"
   
End Sub

Bonjour,

J'ai fait un test avec SharePoint....ça semble fonctionner