Bonjour
Il y a quelque temps j'avais récupéré le code ci-dessous (en cas de besoin) je ne me souviens pas de la source.
Idéalement se serait bien qu'il fonctionne en 32 et 64bit.
J'ai réussi à le faire fonction en 64 bits mais les propriétés dans mon cas les exifs des photo ne sont pas dans les bonnes colonnes, par exemple l'auteur est en ''Genre" U1, le copyright en date de cliché Z1. et certains exifs ne s'affichent pas.
Mon niveau VBA est limité et je ne sais pas ou modifier le code pour que les mots en ligne 1 correspondent bien aux propriétés du fichier.
Le principal but à l'origine était de lister les fichiers du répertoire racine et des sous répertoires avec leurs chemins jusqu'a la découverte du code ci-dessous qui me plait bien...
Pouvez-vous m'aider ?
Merci
Edit :
Pour infos, erreur d'affichage à partir du code 8 jusqu'à la fin, bien sur, je n'ai pas besoin de tout mais des principaux : Nom du fichier, les dates, mot clé, auteur, copyright, commentaires, chemin
En les remettant dans l'odre dans la macro, c'est calé, l'idéal serait de selectionner que ceux que l'on veut (sans colonne vide).
Il y a quelque temps j'avais récupéré le code ci-dessous (en cas de besoin) je ne me souviens pas de la source.
Idéalement se serait bien qu'il fonctionne en 32 et 64bit.
J'ai réussi à le faire fonction en 64 bits mais les propriétés dans mon cas les exifs des photo ne sont pas dans les bonnes colonnes, par exemple l'auteur est en ''Genre" U1, le copyright en date de cliché Z1. et certains exifs ne s'affichent pas.
Mon niveau VBA est limité et je ne sais pas ou modifier le code pour que les mots en ligne 1 correspondent bien aux propriétés du fichier.
Le principal but à l'origine était de lister les fichiers du répertoire racine et des sous répertoires avec leurs chemins jusqu'a la découverte du code ci-dessous qui me plait bien...
Pouvez-vous m'aider ?
Merci
Edit :
Pour infos, erreur d'affichage à partir du code 8 jusqu'à la fin, bien sur, je n'ai pas besoin de tout mais des principaux : Nom du fichier, les dates, mot clé, auteur, copyright, commentaires, chemin
En les remettant dans l'odre dans la macro, c'est calé, l'idéal serait de selectionner que ceux que l'on veut (sans colonne vide).
| Code | réel | affiché par la macro |
| 8 | Disponibilité | Propriétaire |
| 9 | Type identifié | Auteur |
| 10 | Propriétaire | Titre |
| 11 | Sorte | Sujet |
| 12 | Prise de vue | Catégorie |
| 13 | Interprètes ayant participé | Pages |
| 14 | Album | Commentaires |
| 15 | Année | Copyright (normalement le code est 25 sur mon PC (Win10 Pro 64bits) |
VB:
' Références A COCHER Microsoft Scripting Runtime
' Microssoft Shell Controls and Automation
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
Option Explicit
Dim i As Long, k As Long
Dim oShell As Shell, oFolder As Shell32.Folder, oFolderItem As Shell32.FolderItem
Dim FSO As FileSystemObject, Dossier As Scripting.Folder, Fichier As Scripting.File
Dim Debut As Currency, Fin As Currency, Freq As Currency, NbDossiers As Long
Dim TypeFichier As String
Private Sub ExtractionDonnees(sDossier As String)
Dim LastRow As Long, j As Long
Application.ScreenUpdating = False
With Feuil1
Cells.Clear
.Range("A1") = "Nom"
.Range("B1") = "Taille"
.Range("C1") = "Type"
.Range("D1") = "Date Modification"
.Range("E1") = "Date Création"
.Range("F1") = "Date Dernier Accès"
.Range("G1") = "Attributs"
.Range("H1") = "Etat"
.Range("I1") = "Propriétaire"
.Range("J1") = "Auteur"
.Range("K1") = "Titre"
.Range("L1") = "Sujet"
.Range("M1") = "Catégorie"
.Range("N1") = "Pages"
.Range("O1") = "Commentaires"
.Range("P1") = "Copyright"
.Range("Q1") = "Artiste"
.Range("R1") = "Titre Album"
.Range("S1") = "Année"
.Range("T1") = "N° de Piste"
.Range("U1") = "Genre"
.Range("V1") = "Durée"
.Range("W1") = "Vitesse Transmission"
.Range("X1") = "Protégé"
.Range("Y1") = "Modele Appareil Photo"
.Range("Z1") = "Date Cliché"
.Range("AA1") = "Dimension"
.Range("AB1") = "Largeur"
.Range("AC1") = "Hauteur"
.Range("AD1") = "Nom Episode"
.Range("AE1") = "Description Programme"
.Range("AF1") = "Taille Echantillon Audio"
.Range("AG1") = "Fréquence Echantillonnage"
.Range("AH1") = "Chemin"
End With
k = 2
Set oShell = New Shell
Set FSO = New Scripting.FileSystemObject
Set Dossier = FSO.GetFolder(sDossier)
NbDossiers = NbDossiers + 1
For Each Fichier In Dossier.Files
If UCase$(TypeFichier) = UCase$(FSO.GetExtensionName(Fichier)) Then
Set oFolder = oShell.Namespace(Dossier.Path)
Set oFolderItem = oFolder.ParseName(Fichier.Name)
i = 1
With Feuil1
For j = 0 To 34
If j <> 31 Then
.Range(NumCol2Lettre(i) & k) = oFolder.GetDetailsOf(oFolderItem, j)
i = i + 1
End If
Next j
.Range(NumCol2Lettre(i - 1) & k) = sDossier
Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k - 1
k = k + 1
End With
End If
Next Fichier
RchRecursive Dossier
FormatAttributs
With Feuil1
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A1:AH" & LastRow).WrapText = False
.Range("1:1").Font.Bold = True
.Rows("2:2").Select
ActiveWindow.FreezePanes = True
.Columns("A:AH").EntireColumn.AutoFit
.Range("A1:AH1").Interior.ColorIndex = 36
.Range("D2:F" & LastRow).NumberFormat = "dd/mm/yyyy hh:mm:ss"
.Range("AF2:AF" & LastRow).NumberFormat = "dd/mm/yyyy hh:mm:ss"
End With
Tri
Feuil1.Activate
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
Set FSO = Nothing
Set oShell = Nothing
Set Dossier = Nothing
Set oFolder = Nothing
Set oFolderItem = Nothing
Set Fichier = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub FormatAttributs()
Dim LastRow As Long
LastRow = Feuil1.Range("G" & Rows.Count).End(xlUp).Row + 1
Feuil1.Range("G2:G" & LastRow).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
End Sub
Private Function NumCol2Lettre(iNumCol As Long) As String
Dim i As Long, sStr As String
i = iNumCol
sStr = ""
Do While i > 0
sStr = Chr$(((i - 1) Mod 26) + 65) & sStr
i = (i - 1) \ 26
Loop
NumCol2Lettre = sStr
End Function
Private Sub RchRecursive(sFolder As Scripting.Folder)
Dim SousDossier As Scripting.Folder
Dim j As Long
For Each SousDossier In sFolder.SubFolders
Set Dossier = FSO.GetFolder(SousDossier)
NbDossiers = NbDossiers + 1
For Each Fichier In SousDossier.Files
If UCase$(TypeFichier) = UCase$(FSO.GetExtensionName(Fichier)) Then
Set oFolder = oShell.Namespace(Dossier.Path)
Set oFolderItem = oFolder.ParseName(Fichier.Name)
i = 1
With Feuil1
For j = 0 To 34
If j <> 31 Then
.Range(NumCol2Lettre(i) & k) = oFolder.GetDetailsOf(oFolderItem, j)
i = i + 1
End If
Next j
.Range(NumCol2Lettre(i - 1) & k) = sFolder
k = k + 1
End With
End If
Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k
Next Fichier
RchRecursive SousDossier
Next SousDossier
End Sub
Sub SelDossier()
Dim sChemin As String
sChemin = ThisWorkbook.Path
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = sChemin & "\"
.Title = "Sélectionner le Dossier à traiter"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.ButtonName = "Sélection Dossier"
.Show
If .SelectedItems.Count > 0 Then
DoEvents
TypeFichier = InputBox( _
"Donnez seulement le type de fichier (par exemple pdf, xls, doc, jpg ou dxf etc...)" _
, "TYPE DE FICHIER", "stl")
QueryPerformanceCounter Debut
NbDossiers = 0
ExtractionDonnees .SelectedItems(1)
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k - 2 & " / " & Format((Fin - Debut) / Freq, "0.00 s")
End If
Feuil1.Range("C1").Select
End With
End Sub
Private Sub Tri()
Dim LastRow As Long
LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
Feuil1.Range("A2:AH" & LastRow).Sort Key1:=Feuil1.Range("A2"), Order1:=xlAscending, Key2:=Feuil1.Range("B2") _
, Order2:=xlAscending, Key3:=Feuil1.Range("C2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
End Sub
Dernière édition:
