Choisir repertoire, modifier un code existant ?

[re4]

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 (?)

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

 

[re4]

Re : Choisir repertoire, modifier un code existant ?

Bonjour,
Je sais qu'il y a beaucoup de post, y aurait il quelqu'un pour m'aiguiller (m'aider ;-) ? Je ne sais vraiment pas comment faire.
Merci beaucoup
Bien à vous

 

[Roland_M]

Re : Choisir repertoire, modifier un code existant ?

bonsoir,

il y a un appel d'une routine "Efface_Images" qui j'espère existe bien chez toi !?

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 Chemin$, Test$, F$  ' le répertoire de base + var

'saisie du chemin
Chemin$ = FLoadNomDuREP: If Chemin$ = "" Then Exit Sub

Set Ws = Sheets("Feuil1")                   ' Nom de la feuille
Application.ScreenUpdating = False          ' Interdit le raffraîchissement d'écran
Efface_Images ' <<<<<<<<<< j'espère que cette appel routine existe chez toi !?
  
With Ws
 For Lg = 1 To .Range("B" & Rows.Count).End(xlUp).Row ' Parcourt de toute la colonne B
     F$ = .Cells(Lg, "B")
     If Trim(F$) > "" Then
        Image = Dir(Chemin$ & F$)
        If Image > "" Then
           With .Pictures.Insert(Image).ShapeRange        ' On insère l'image dont le nom est en colonne B
           '.LockAspectRatio = msoFalse                   ' On peut la redimensionner 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
        Else
           MsgBox F$ & " est inexistante!?"
        End If
     End If
 Next Lg
End With
End Sub

Public Function FLoadNomDuREP() As String
With Application.FileDialog(msoFileDialogFolderPicker)
  .ButtonName = "OK"
  .InitialFileName = ThisWorkbook.Path & "\"
  .Title = "Sélectionnez un dossier"
  .Show
  If .SelectedItems.Count > 0 Then FLoadNomDuREP = .SelectedItems(1) & "\" Else FLoadNomDuREP = ""
 'ou direct
 'If .Show = -1 Then FLoadNomDuRep = .SelectedItems(1)& "\" Else FLoadNomDuRep = ""
End With
End Function

 

[re4]

Re : Choisir repertoire, modifier un code existant ?

Bonsoir Roland_M et merci beaucoup pour ton efficace réponse.

Oui il y a une routine ''efface'', qui marche bien enfin qui efface bien ;-)
Ton code est nickel, c'est exactement ce que je cherchais, il me reste encore à l'amélioré (si j'y arrive) je ne suis pas spécialiste du VBA !
Juste une petite précision, est 'il normal que ça ne marche pas si le fichier Excel est dans le même répertoire que les photos ?

Voici ce que j'aimerai amélioré : renseignement des colonnes B, C, D, puis insertion des images en colonne A
colonne A => affichage des images => grâce à toi, ok
colonne B => liste des fichiers du même répertoire (donc des photos)
Colonne C => le nom de l'auteur (exif)
Colonne D => la date de prise de vue (exif)

Encore merci
Uge

 

[Roland_M]

Re : Choisir repertoire, modifier un code existant ?

Bonjour,

quelque chose comme ça !?
(le code part d'une macro de LSteph)

EDIT: à ta demande j'ai modifié la sélection répertoire !

pour le fichier, voir le post#12

 

[re4]

Re : Choisir repertoire, modifier un code existant ?

Bonjour
Exactement ça ! bravo et merci, je vais enlever (enfin si j'arrive à décortiquer) certaines colonnes et ne garder que les principales.
Juste un petit détail mais ça n'a pas trop d'importance, est 'il possible d'avoir l'ouverture de répertoire ''type Windows" celui que l'on peut redimensionner ? A part ce petit détail c'est top !

Merci beaucoup pour ton implication, demain je testerai plus longuement avec des gros répertoires de photos
Bien à toi

 

[Roland_M]

Re : Choisir repertoire, modifier un code existant ?

bonsoir,

EDIT: pour le fichier, voir le post#12

 

[re4]

Re : Choisir repertoire, modifier un code existant ?

Top de top
Merci Roland_M

Bonne soirée

 

[re4]

Re : Choisir repertoire, modifier un code existant ?

Bonsoir Roland_M
Je me permets de revenir vers toi pour un retour
le bouton ''nettoyer'' n'efface pas les imagettes
Comment faire pour enlever le n° devant les titres ? (ex : 4'Date de création)

J'ai besoin de:
Nom fichier
nom auteurs
Copyright
Dimension
Poids

J'ai fait ces modifs (je ne sais pas simplifier), il est certainement possible de faire une boucle...

 'For I = 0 To 50
I = 0 'nom du fichier
'If myFolder.GetDetailsOf(myFile, I) <> "" Then   '(n'était pas actif)
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 20 ' Auteurs
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 25 ' Copyright
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 4 'date de création
Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 31 ' Dimensions
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
I = 1 ' poids
  Col = Col + 1: Cells(Lig, Col) = myFolder.GetDetailsOf(myFile, I)
 'Next

D'autre part les numéros de certains titres ne sont pas les mêmes suivant l'os Win7, 8, 10
Là je test sous win 7 :
'Infos pour Windows 7
'0=Nom '20=Auteurs '25=Copyright '4=date de création '31=dimensions '1=poids

Je dois finaliser sous win10, j'arriverai bien à trouver les bon n° ;-)

J'ai une autre macro qui me fait les extractions des exifs avant de décider de faire des fichiers avec imagettes mais ce n'est pas la même utilisation. Il est vrai que j'aurais pu utilser le code existant mais je ne sais pas faire (il suffisait d'y ajouter la routine pour les imagettes.

Si tu as le temps mais ce n'est pas vraiment indispensable pour l'instant, par la suite je voudrai ajouter des lien hyper au noms des fichiers.

Je réfléchi à un userform pour sélectionner le type d'image (JPG, jpeg, CR2, Raw, ect)
avec liens HyperText ou pas avec nom du répertoire ou pas, mais se sera quand on sera riche

Merci encore de ton aide, ça nous sera très utile pour notre club photos
Bien à toi

 

[Roland_M]

Re : Choisir repertoire, modifier un code existant ?

Bonsoir,

voir déjà avec cette modif !?

pour les liens c'est pas compliqué mais c'est pour quoi faire localiser l'image ou exécuter pour l'affichage ?
maintenant pour autre que jpg ça ne sera pas pareil pour lire les données exif !

tu dis que pour les nos ce n'est pas pareil sous 2010 ? c'est bizarre !?

EDIT: pour le fichier, voir le post#12

 

[re4]

Re : Choisir repertoire, modifier un code existant ?

Bonsoir
Ok ça marche, je ne connaissais pas ''Choose(x....''
La fonction effacer n'efface pas les images
Pour les hyper text, c'est pour visualiser l'image dans un player

Bribe du code que j'utilise dans le fichier dont je te parlais

'Dans l'ordre d'affichage pour Win7
' 0= Nom du fichier
'20 Auteurs
'1 Taille
'162 Pixels H
'164' Pixels V

   Arr = Array(0, 20, 1, 162, 164) 'Win 7
  'Arr = Array(0, 20, 1, 167, 169) 'Win 8
  'Arr = Array(0, 20, 1, 169, 171) ' Win 10

Set objShell = CreateObject("Shell.Application")

Set objfolder = objShell.Namespace(CStr(Répertoire))


Application.ScreenUpdating = False
  Application.EnableEvents = False

L'on voit bien que certains numéros ne correspondent pas.
Merci beaucoup


23:38 Je viens de tester ton fichier sous win 10, c'est ok pour les 5 colonnes !

ps : si ça t'intéresse je t'envoie le code en entier

 

[Roland_M]

Re : Choisir repertoire, modifier un code existant ?

Bonjour,

je veux bien pour voir !?

mais concernant l'effacement il y a eu un hic car j'avais déjà fais cette modif mais elle n'y est plus !?
probablement une mauvaise manoeuvre !?

si tu veux bien le reprendre, j'ai fais la modif et qq améliorations ...

pour toi voir les Noms et les Types exactes j'ai mis un Msgbox dans la boucle.
tu charges tes images, puis tu vas enlever la rem( ' ) devant cette ligne puis tu cliqueras sur le bouton nettoyer


EDIT: code modifié pour le type d'image voir code module dans Sub NettoyeFeuilActive()

 

[re4]

Re : Choisir repertoire, modifier un code existant ?

Bonsoir,
en supprimant le rem je vois bien le nombre d'image dans la mgbox mais pas d'action effacer sur les images, mystère....

Voici le code qui me permet d'extraire le nom des fichiers avec les exifs (ce code n'est pas de moi, je l'ai adapté à mon utilisation). La prochaine étape sera de renommer les fichiers après vote dans un autres répertoire, mais ça je ne sais pas encore comme m'y prendre... ;-)

Merci

' Extraction des exifs photos
Sub Extract()

'--------------------------------------------------------------------------------
Dim Rep As Integer
       Rep = MsgBox("Ceci va effacer les données existantes''.                                             Voulez-vous continuez ?", vbYesNo + vbQuestion, "AVERTISSEMENT")
    If Rep = vbYes Then
    
    ' Desactive les filtres
              'If Sheets("Extract").AutoFilterMode Then Sheets("Extract").[A2].AutoFilter
         If Sheets("Extract").AutoFilterMode = True Then Sheets("Extract").[A2].AutoFilter
         
            [a3:e1000].ClearContents
    
        ' si réponse positive Extraction des Exifs
        ' ...
    Else
        ' si réponse négative, l'on sort
        ' ...
        Exit Sub
    End If
'-------------------------------------------------------------------------------

 Dim Arr(), Elt As Variant, i As Long
 Dim det_Headers(0 To 7), X As String
 Dim Répertoire As String

Répertoire = SelDossier(Répertoire)
If Répertoire = "" Then MsgBox "Opération annulée.": Exit Sub


'La liste des numéros de champs dont l'on veut extraire la valeur
'0= nom fichier, win7, 8, 10
'1 = Taille, win7, 8, 10
'20 = Auteurs, win7, 8, 10
'162 = Pixels H (win7) 167 (win8) 168 (win10)
'164 = Pixels V (win7) 169 (win8) 171 (win10)

  'Arr = Array(0, 1, 20, 166, 167, 169) old
   Arr = Array(0, 20, 1, 162, 164) 'Win 7
  'Arr = Array(0, 20, 1, 167, 169) 'Win 8
  'Arr = Array(0, 20, 1, 169, 171) ' Win 10

Set objShell = CreateObject("Shell.Application")

Set objfolder = objShell.Namespace(CStr(Répertoire))


Application.ScreenUpdating = False
  Application.EnableEvents = False


With ThisWorkbook
      With .Sheets("Extract") 'Adapter le nom de la feuille
          .Activate
          'For Each Elt In Arr
          '    det_Headers(i) = objfolder.GetDetailsOf(objfolder.Items, Elt)
          '    .Cells(1, i + 1) = det_Headers(i)
           '   i = i + 1
         ' Next
         
    
        j = 3: i = 0 'j=3 données en ligne 3
      
      
        For Each strFileName In objfolder.Items
              For Each Elt In Arr
                  Select Case Elt
'Rentrer tous les numéros des champs qui ont une valeur numérique, supprime les Caractères
                    Case 162, 164  'pour les données numériques win7
                    'Case 167, 169  'pour les données numériques win 8
                    'Case 169, 171 'pour les données numériques win 10
                                           
                          X = objfolder.GetDetailsOf(strFileName, Elt)
                          If Not IsNumeric(Left(X, 1)) Then
                             X = Right(X, Len(X) - 1)
                          End If
                          .Cells(j, i + 1).Value = Val(Replace(Trim(X), ",", "."))
                      Case Else
                          .Cells(j, i + 1).Value = Trim(objfolder.GetDetailsOf(strFileName, Elt))
                  End Select
                  i = i + 1
              Next
               j = j + 1: i = 0
               
          Next
          
       
          
      ' '   .UsedRange.EntireColumn.AutoFit
      End With
  End With



Application.ScreenUpdating = True
 Application.EnableEvents = True
 
  '' Columns("S:U").Select
   '' Range("S3").Activate
  ''  Selection.EntireColumn.Hidden = True
    
 Range("A3").Select
 
 ' MsgBox "Fichier Excel à enregistrer dans le dossier des photos"
 

 End Sub
 


'------------------------------------------------------------------

Function SelDossier(Defaut As String)
 Dim FD As FileDialog
 Set FD = Application.FileDialog(msoFileDialogFolderPicker)
 With FD
     .InitialFileName = Defaut
     If .Show = -1 Then
         SelDossier = FD.SelectedItems(1)
    End If
 End With
 Set FD = Nothing
 End Function

'------------------------------------------------------------------

 

[Roland_M]

Re : Choisir repertoire, modifier un code existant ?

bonsoir,

mais alors où est passé le code que je t'ai fais ? il ne sert à rien là dedans !
quel était l'utilité de mon travail !? je ne comprend pas !?

quand à l'affichage avec msgbox tu dois voir le nom et le type de l'image ce n'est pas possible autrement !?

et les images doivent être supprimé que ce soit avec son type no 13 ou son nom !?
je ne comprend plus rien à ta démarche !?

 

[re4]

Re : Choisir repertoire, modifier un code existant ?

Roland,
Pas de souci ton code est utilisé pour ce que je voulais à savoir insérer des images dans des cellules à partir du nom des fichiers + les exif. Ca c'est super et tu m'as bien aidé et ça marche très bien sauf que lorsque je clique sur effacer, ça efface les exifs mais pas les photos.

Je t'ai envoyé l'autre code parce que je t'en avais parlé et que j'ai cru comprendre que tu voulais voir par curiosité en interprétant le ''je veux bien pour voir''...
Ce code est utilisé pour tout autre chose, rien à voir avec notre sujet.

J'espère que je n'ai pas fait d'impair, je ne voulais pas te froisser, et te demande de m'excuser si c'est le cas, ton travail m'est très utile.

Reste juste le problème d'effacer toute la feuille, ça ne marche pas sur mon appareil win7

La msgbox me donne bien le nom de l'image.
Voici ci-dessous le résultat en image de ce que j'ai dans la feuille


Ici seules les colonnes B à G s'effacent lorsque je clique sur ''nettoyer la feuille''

Encore merci beaucoup pour ton excellent travail, bonne soirée.
Uge