Modifier code, ajouter choisir un repertoire

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

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

bonjour voici une petite fonction qui demande a l'utilisateur de choisir un dossier

fred

Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function

Merci beaucoup pour votre réponse, je l'insère ou dans le précèdent code et la place de quoi ?

bonjour

il faut creer une variable exempel :

dim dossier as string 

puis appeler la fonction donnée et stocker le retour de cette fonction dans cette variable :

dossier = ChoixDossier

et ensuite remplacer

Image = ThisWorkbook.Path & "\Test photos\" & .Cells(Lg, "B")        ' Répertoire à actualiser

par

Image = dossier  & "\Test photos\" & .Cells(Lg, "B")        ' Répertoire à actualiser

fred

Bonsoir,

J'ai essayé mais je ne sais pas vraiment ou insérer exactement les codes que tu me donnes. Je ne suis pas un programmeur, je m'y intéresse mais je suis bien loin d'avoir ton niveau

Merci de ta compréhension

voila le code en entier

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
Dim dossier as string

dossier = ChoixDossier

  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
     Image = dossier  & "\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
Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function

Bonjour

Merci pour ta réponse, lorsque je lance la macro, ça affiche 'image inexistante (j'ai 3 image JPG dans le répertoire que je choisi.

Peux tu m'explique pourquoi il y a un nom de répertoire ''test photos'' dans cette ligne : Image = dossier & "\Test photos\" & .Cells(Lg, "B")

Bonne journée

bonjour

bah comment dire .... c'est dans ton code original.... si tu en as pas besoin supprime ce sous dossier....

fred

Bonjour Fred2406

Ok je l'ai mis en rem mais toujours images inexistante.

Ni les exifs ni les images ne sont récupérés.

Je n'ai pas écrit le code, je ne connais pas trop le VBA, je sais y ''bidouiller" si l'on me guide...

Merci de ton aide

Met ceci à la place

  Image = dossier  & "\" & .Cells(Lg, "B")

car la fonction que je t'ai donné ne met pas le seprateur "\"

et quand tu es dans le vba project fait dérouler le code pas a pas (touche F8) et comme cela tu peux voir le contenue des différentes variables pour vérifier leur valeur

fred

J'ai fait ce que tu m'as dit, ça déroule jusqu'au bout sans erreur mais toujours page désespérément vide

fourni un fichier test avec deux images pour test

fred

Voici le fichier,

Merci pour ton analyse