Bonjour
J'ai récupéré le code ci-dessous qui fonctionne bien, mais je voudrais pouvoir choisir le répertoire ou il y a les photos
ici le répertoire est en dur : Image = ThisWorkbook.Path & "\Test photos\" & .Cells(Lg, "B") , mes connaissances en VBA ne me permettent pas de le modifier.
En vous remerciant beaucoup pour votre aide
Bonne journée
ps: déontologiquement je ne sais s'il faut mettre le lien du forum ou j'ai récupéré ce code (?)
J'ai récupéré le code ci-dessous qui fonctionne bien, mais je voudrais pouvoir choisir le répertoire ou il y a les photos
ici le répertoire est en dur : Image = ThisWorkbook.Path & "\Test photos\" & .Cells(Lg, "B") , mes connaissances en VBA ne me permettent pas de le modifier.
En vous remerciant beaucoup pour votre aide
Bonne journée
ps: déontologiquement je ne sais s'il faut mettre le lien du forum ou j'ai récupéré ce code (?)
HTML:
Option Explicit
Sub Affiche_Image()
Dim Ws As Worksheet ' Sert à manipuler plus facilement l'objet feuille
Dim Image As String ' Contiendra le nom de l'image
Dim Lg As Long ' Numéro de la dernière ligne colonne B
Set Ws = Sheets("Feuil1") ' Nom de la feuille
Application.ScreenUpdating = False ' Interdit le raffraîchissement d'écran
Efface_Images
With Ws
For Lg = 1 To .Range("B65536").End(xlUp).Row ' Parcourt de toute la colonne B
Image = ThisWorkbook.Path & "\Test photos\" & .Cells(Lg, "B") ' Répertoire à actualiser
On Error Resume Next ' On s'affranchit des erreurs
With .Pictures.Insert(Image).ShapeRange ' On insère l'image dont le nom est en colonne B
'.LockAspectRatio = msoFalse ' On peut la redimmensionner comme on veut
.LockAspectRatio = msoTrue
.Left = Ws.Cells(Lg, "A").Left ' Position gauche
.Top = Ws.Cells(Lg, "A").Top ' Position Haut
.Width = Ws.Cells(Lg, "A").Width ' Largeur
.Height = Ws.Cells(Lg, "A").Height ' hauteur
End With
If Err.Number > 0 Then ' Si une erreur (image non présente)
MsgBox .Cells(Lg, "B") & vbCr & "Image inexistante" ' On le signale
End If
Next Lg
End With
End Sub
Dernière édition: