XL 2019 lister fichier avec exifs ou propriétés

re4

XLDnaute Occasionnel
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).
Coderéelaffiché par la macro
8DisponibilitéPropriétaire
9Type identifiéAuteur
10PropriétaireTitre
11SorteSujet
12Prise de vueCatégorie
13Interprètes ayant participéPages
14AlbumCommentaires
15AnnéeCopyright (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:

Discussions similaires

Réponses
4
Affichages
199
Haut Bas