Gestion de noms de fichiers et de métadonnées

[Kapparho]

Lecteur salut,

Répertoire avec un grand nombre de photos de plantes, toutes nommées DSC01.jpg, DSC02.jpg, …, DSC99.jpg.

1) Est-il possible de faire apparaître en Excel :
En colonne A leurs noms (DSC01.jpg, DSC02.jpg, …, DSC99.jpg).
En colonne B une métadonnée, p.ex. Titre
En colonne C, une autre métadonnée, p.ex. Artiste
Si possible en colonne D une miniature de la photo.

2) En Excel, on peut évidemment :
- Mentionner les Titres en colonnes B. Ex. Rose, Rose, Tulipe, Tulipe…
Mentionner les Artistes (photographes) en colonne C. Ex. Jean, Marie, Luc, Anne
Changer les noms en colonne A. Ex.
DSC01.jpg devient Rose - Jean.jpg
DSC02.jpg devient Rose - Marie.jpg
DSC03.jpg devient Tulipe - Luc.jpg
DSC04.jpg devient Tulipe - Anne.jpg

3) Question :
Comment faire, au départ du fichier Excel pour :
- Enregistrer les métadonnées
- Modifier les noms des photos ?

Grand merci à qui trouvera une réponse.
Kapparho

 

[PMO2]

Re : Gestion de noms de fichiers et de métadonnées

Bonjour,

Pour répondre à votre 1ère question voici un code compliqué dans lequel il faudra
adapter à votre convenance la constante

Const MON_DOSSIER = "C:\Dossier vacances"

Copiez le code suivant dans un module standard

'### Constante du dossier et son chemin à adapter ###
Const MON_DOSSIER = "C:\Dossier vacances"
'####################################################

Sub PropertiesFile()
Dim ShellApp As Object  'Shell32.Shell
Dim Fichier As Object   'Shell32.FolderItem
Dim Dossier As Object   'Shell32.Folder
Dim mesDetails
Dim i&
Dim j&
Dim T()
Dim S As Worksheet
Dim R As Range
mesDetails = Array(0, 10, 16, 9)
Set ShellApp = CreateObject("Shell.Application")
Set Dossier = ShellApp.Namespace(MON_DOSSIER)
If Dossier Is Nothing Then
  MsgBox "Le dossier ''" & MON_DOSSIER & "'' est introuvable."
  Exit Sub
End If
ReDim T(1 To Dossier.Items.Count + 1, 1 To UBound(mesDetails) + 1)
For Each Fichier In Dossier.Items
  i& = i& + 1
  If i& = 1 Then
    For j& = 0 To UBound(mesDetails)
      T(i&, j& + 1) = Dossier.GetDetailsOf(Dossier.Items, mesDetails(j&))
    Next j&
  Else
  For j& = 0 To UBound(mesDetails)
    T(i&, j& + 1) = Dossier.GetDetailsOf(Fichier, mesDetails(j&))
  Next j&
  End If
Next Fichier
Set S = Sheets.Add
Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 1), UBound(T, 2)))
R = T
With S.Range(S.Cells(1, 1), S.Cells(1, UBound(T, 2)))
  .Font.Bold = True
  .HorizontalAlignment = xlCenter
  .Interior.ColorIndex = 34
End With
S.Columns.AutoFit
Set ShellApp = Nothing
Call ChargePicture
Call CompressionImage
End Sub
 
Sub ChargePicture(Optional dummy As Byte)
Dim var
Dim bool As Boolean
Dim i&
Dim A$
Dim R As Range
Dim PICT As Picture
On Error GoTo Erreur
var = ActiveSheet.UsedRange
For i& = 2 To UBound(var, 1)
  A$ = UCase(Mid(var(i&, 1), InStrRev(var(i&, 1), ".") + 1))
  If A$ = "BMP" Or A$ = "JPG" Or A$ = "JPEG" Then
    bool = True
    Exit For
  End If
Next i&
If Not bool Then Exit Sub
Application.ScreenUpdating = False
For Each PICT In ActiveSheet.Pictures
  PICT.Delete
Next PICT
Rows("2:" & UBound(var, 1) & "").RowHeight = 39
Columns(3).ColumnWidth = 9.57
For i& = 2 To UBound(var, 1)
  A$ = UCase(Mid(var(i&, 1), InStrRev(var(i&, 1), ".") + 1))
  If A$ = "BMP" Or A$ = "JPG" Or A$ = "JPEG" Then
    Set R = Range("e" & i& & "")
    Set PICT = ActiveSheet.Pictures.Insert(MON_DOSSIER & "\" & var(i&, 1))
    With PICT
     .Top = R.Top
     .Left = R.Left
     .Width = R.Width
     .Height = R.Height
     .Placement = xlMoveAndSize
     .OnAction = "sansAction" 'Sans action : Evite la sélection de l'image
    End With
  End If
Next i&
Application.ScreenUpdating = True
Exit Sub
Erreur:
Application.ScreenUpdating = True
End Sub

Sub sansAction(Optional dummy As Byte)
'''vide de traitement, mais nécessaire pour éviter la sélection de l'image
End Sub

Sub CompressionImage(Optional dummy As Byte)
Dim C As Object
Dim PICT As Picture
Dim bool As Boolean
For Each PICT In ActiveSheet.Pictures
  bool = True
  Exit For
Next PICT
If Not bool Then Exit Sub
Application.ScreenUpdating = False
For Each C In Application.CommandBars("Picture").Controls
  If TypeOf C Is CommandBarButton Then
    If C.ID = 6382 Then
      Application.SendKeys _
        "{DOWN}{TAB}{UP}{ENTER}{ENTER}", True
      C.Execute
      Exit For
    End If
  End If
Next C
Application.ScreenUpdating = True
End Sub

Cordialement.

PMO
Patrick Morange

 

[Kapparho]

Re : Gestion de noms de fichiers et de métadonnées

Un tout grand merci à Patrick Morange.
Je tacherai dès que possible de mettre en oeuvre vos suggestions.