Master file detail list

**Lockie78** · 05-25-2020, 02:28 AM

Hello

I would like to have a master list that list all files in a folder and sub-folders is B3 is TRUE. Someone has created a code that does this but it lists all fields in the one column (code is here https://officetricks.com/excel-vba-g...ied-date-time/).

I would like the information returned as shown in the attached template. I have listed the "oDir.GetDetailsOf" number in brackets in row 5, ie File Path = file property number 177 from oDir.GetDetailsOf.

I am using Windows 10 64-bit operating system but also use a 32-bit operating system too, not sure if that matters but if it does 64-bit is more important than 32-bit.

Please let me know if i have missed any information needed and thank you very much.

**Logit** · 05-25-2020, 04:23 PM

.
To simplify matters .. here are two examples for you to review. Providing code here for one of the workbooks :

' ----------------------------------------------------------------------------------------------------------------------------------'   VBA Project:    Retrieve a list of all files from a folder and its subfolders
'   Module:         modRetrieveFiles
'   Author:         Robert Mundigl
'   Copyright:      © 2016 by Robert Mundigl, Clearly and Simply, www.clearlyandsimply.com. All rights reserved.
'   Last edit:      29th of August 2016
'   Purpose:        Retrieve all files within a specified folder and all its subfolders and create a list of all file names & paths
' ----------------------------------------------------------------------------------------------------------------------------------


Option Explicit


Public varFileList As Variant
Public dblTimerResult As Double
Public lngFiles As Long


' ----------------------------------------------------------------------------------------------------------------------------------
Sub RetrieveFilesandFolders()
' Main routine to retrieve all files from a user defined folder and its subfolders
Dim intDialogue As Integer
Dim lngRowCount As Long
Dim strPath As String
Dim objFso As Object


    On Error Resume Next


    ' Initialize
    EHTimer 0
    Application.ScreenUpdating = False
    Application.StatusBar = "Initializing..."
    
    ' Clear existing data and resize list object
    With ActiveSheet
        With .ListObjects("tab_files")
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
            If .DataBodyRange.Rows.Count > 1 Then .DataBodyRange.Offset(1, 0).Resize(.DataBodyRange.Rows.Count - 1, .DataBodyRange.Columns.Count).Rows.Delete
            .DataBodyRange.Rows(1).ClearContents
        End With
        .UsedRange
    End With
   
    ' Open folder dialog window
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Select a Folder."
    intDialogue = Application.FileDialog(msoFileDialogFolderPicker).Show
    
    ' Retrieve the list of files
    If intDialogue <> 0 Then
        strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
        Application.StatusBar = "Detecting count of files..."
        lngFiles = CountFiles(strPath)
        ReDim varFileList(1 To lngFiles, 1 To ActiveWorkbook.Worksheets(1).ListObjects("tab_files").DataBodyRange.Columns.Count)
        Set objFso = CreateObject("Scripting.FileSystemObject")
        lngRowCount = RetrieveFiles(strPath, objFso, 1)
        RetrieveFolders strPath, objFso, lngRowCount
    End If
    
    ' Transfer data to worksheet
    Application.StatusBar = "Updating the data table..."
    With ActiveWorkbook.Worksheets(1).ListObjects("tab_files")
        .Resize ActiveSheet.Range(.Range.Resize(lngFiles + 1, .Range.Columns.Count).Address)
        .DataBodyRange.Value = varFileList
    End With
    
    ' Sort list descending by path length
    Application.StatusBar = "Sorting and finalizing..."
    With ActiveSheet
        .ListObjects("tab_files").Sort.SortFields.Clear
        .ListObjects("tab_files").Sort.SortFields.Add Key:= _
                Range("tab_files[[#All],[Path Length]]"), _
                SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
        
        With .ListObjects("tab_files").Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    
    End With
    
    ' Clean up
    Set objFso = Nothing
    Erase varFileList


    Application.ScreenUpdating = True
    Application.StatusBar = Empty
    
    ' Inform the user
    EHTimer
    MsgBox Format(lngFiles, "#,##0") & " filenames imported. Duration: " & Format(Round(dblTimerResult, 0) / 86400, "hh:mm:ss"), _
            vbInformation, "Import completed"


End Sub


' ----------------------------------------------------------------------------------------------------------------------------------
' Function to retrieve all files inside the defined folder and write the information to the list object on the worksheet
Private Function RetrieveFiles(ByVal strPath As String, ByRef objFso As Object, ByVal lngRow As Long) As Long
Dim lngCount As Long
Dim objFolder As Object
Dim objFile As Object
    
    On Error Resume Next
    
    Set objFolder = objFso.Getfolder(strPath)
    lngCount = lngRow


    If objFolder.Files.Count > 0 Then
        
        For Each objFile In objFolder.Files
            
            If lngCount Mod 100 = 0 Then
                EHTimer
                Application.StatusBar = "Processed files " & Format(lngCount, "#,##0") & " of " & Format(lngFiles, "#,##0") & _
                                        " (" & Format(lngCount / lngFiles, "0%") & " completed). " & _
                                        "Elapsed time: " & Format(Round(dblTimerResult, 0) / 86400, "hh:mm:ss")
                DoEvents
            End If
            
            varFileList(lngCount, 1) = objFile.Name
            varFileList(lngCount, 2) = objFile.Path
            varFileList(lngCount, 3) = objFile.Size
            varFileList(lngCount, 4) = objFile.Type
            varFileList(lngCount, 5) = objFile.DateCreated
            varFileList(lngCount, 6) = objFile.DateLastModified
            varFileList(lngCount, 7) = objFile.DateLastAccessed
            varFileList(lngCount, 8) = Len(objFile.Name)
            varFileList(lngCount, 9) = Len(objFile.Path)
            lngCount = lngCount + 1
        
        Next objFile
    
    End If
    
    RetrieveFiles = lngCount


    Set objFolder = Nothing
    Set objFile = Nothing
    
End Function


' ----------------------------------------------------------------------------------------------------------------------------------
' Sub to loop through all folders inside a defined folder (recursive sub)
Private Sub RetrieveFolders(ByVal strFolder As String, ByRef objFso As Object, ByRef lngRow As Long)
Dim objFolder As Object
Dim objSubFolder As Object
    
    On Error Resume Next
    
    Set objFolder = objFso.Getfolder(strFolder)
        
    For Each objSubFolder In objFolder.subFolders
        With objSubFolder
            lngRow = RetrieveFiles(.Path, objFso, lngRow)
            Call RetrieveFolders(.Path, objFso, lngRow)
        End With
    Next objSubFolder
        
    Set objFolder = Nothing
    Set objSubFolder = Nothing


End Sub


' ----------------------------------------------------------------------------------------------------------------------------------
Private Function CountFiles(strFolder As String) As Long
' Count files in the folder and its subfolders
Dim objFso As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim lngCount As Long


    On Error Resume Next


    ' Initialize
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objSubFolders = objFso.Getfolder(strFolder).subFolders


    'Count files (that match the extension if provided)
    lngCount = objFso.Getfolder(strFolder).Files.Count


    'Count files in subfolders
    For Each objSubFolder In objSubFolders
        lngCount = lngCount + CountFiles(objSubFolder.Path)
    Next objSubFolder
    
    CountFiles = lngCount


End Function


' ----------------------------------------------------------------------------------------------------------------------------------
Public Sub EHTimer(Optional varStart As Variant)
' Timer (provided by Daniel Ferry in the Excel Hero Academy): called when starting and stopping the timer
    If IsMissing(varStart) Then
        dblTimerResult = Timing
    Else
        Timing = 0
    End If
End Sub

**Lockie78** · 05-26-2020, 01:54 AM

Thanks Logit, appreciate the code

It doesnt look like there is a reference to getting the extended property information. I already found a code that will list all the files (see below code "Code that lists files" i have also updated my original post with spreadsheet that has this code in my preferred template that lists the information i need) and i found a code that will list all the properties i need (see below code "Code that gets all extended properties") but i am having trouble trying to make them into one as i cant get my head around VBA with object references.

At the end i have but an example of trying to put them together but i'm not using the right reference or something.

Code that lists files

Dim iRow


Sub ListFiles()
    iRow = 11
    Call ListMyFiles(Range("C7"), Range("C8"))
End Sub


Sub ListMyFiles(mySourcePath, IncludeSubfolders)
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(mySourcePath)
    On Error Resume Next
    For Each myFile In mySource.Files
        iCol = 2
        Cells(iRow, iCol).Value = myFile.Path
        iCol = iCol + 1
        Cells(iRow, iCol).Value = myFile.Name
        iCol = iCol + 1
        Cells(iRow, iCol).Value = myFile.Size
        iCol = iCol + 1
        Cells(iRow, iCol).Value = myFile.DateLastModified
        iRow = iRow + 1
    Next
    If IncludeSubfolders Then
        For Each mySubFolder In mySource.SubFolders
            Call ListMyFiles(mySubFolder.Path, True)
        Next
    End If
End Sub

Code that gets all extended properties

Sub Get_Extended_File_Property()
    Dim sFile As Object, obja
    
    'Create Shell Object & NameSpace
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace("D:\F\Fiverr\tixops123 - Excel App")
    ActiveSheet.Cells.ClearContents
    
    'Loop thru each File/Folder inside Root Directory
    iRow = 1
    For Each sFile In oDir.Items
        iRow = iRow + 1
        
        'Loop thru Each Property
        For i = -1 To 350
            
            'Get File Property Name & Value
            obja = oDir.GetDetailsOf(sFile, i)
            If obja <> "" Then
                iRow = iRow + 1
                ActiveSheet.Range("A" & iRow) = i
                
                'Enter File Property to Sheet
                ActiveSheet.Range("B" & iRow) = oDir.GetDetailsOf(oDir, i)
                ActiveSheet.Range("C" & iRow) = obja
            End If
        Next
    Next
    
    MsgBox "Process Completed"
End Sub

Example of joining code

Dim iRow


Sub ListFiles()
    iRow = 11
    Call ListMyFiles(Range("C7"), Range("C8"))
End Sub


Sub ListMyFiles(mySourcePath, IncludeSubfolders)
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace(mySourcePath)
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(mySourcePath)
    On Error Resume Next
    For Each myFile In mySource.Files
        iCol = 2
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 192)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 0)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 2)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 165)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 1)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 3)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 4)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 12)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 209)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 27)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 316)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 317)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 315)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 320)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 321)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 28)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 319)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 31)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 177)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 179)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 176)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 178)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 175)
        iCol = iCol + 1
        Cells(iRow, iCol).Value = oDir.GetDetailsOf(myFile, 271)
        iRow = iRow + 1
    Next
    If IncludeSubfolders Then
        For Each mySubFolder In mySource.SubFolders
            Call ListMyFiles(mySubFolder.Path, True)
        Next
    End If
End Sub

Really appreciate the time and help. Thanks!

**Lockie78** · 05-26-2020, 01:57 AM

Updated file as per above. Couldn't figure out how to update my original post. Thanks

**Lockie78** · 05-26-2020, 02:36 AM

Ok, i got it working to return all the information i need (code is messy though), i just need to figure out how to make it so it will look in sub folders and then work on formatting dates.

Sub Get_Extended_File_Property()    Dim sFile As Object, obja
    
    'Create Shell Object & NameSpace
    Set oShell = CreateObject("Shell.Application")
    Set oDir = oShell.Namespace(Range("B7").Value)
    
    
    'Loop thru each File/Folder inside Root Directory
    iRow = 10
    For Each sFile In oDir.Items
        iRow = iRow + 1
        
        'Loop thru Each Property


            
            'Get File Property Name & Value
            obja = oDir.GetDetailsOf(sFile, 0)
            If obja <> "" Then
                ActiveSheet.Range("A" & iRow) = oDir.GetDetailsOf(sFile, 192)
                ActiveSheet.Range("B" & iRow) = oDir.GetDetailsOf(sFile, 0)
                ActiveSheet.Range("C" & iRow) = oDir.GetDetailsOf(sFile, 2)
                ActiveSheet.Range("D" & iRow) = oDir.GetDetailsOf(sFile, 165)
                ActiveSheet.Range("E" & iRow) = oDir.GetDetailsOf(sFile, 1)
                ActiveSheet.Range("F" & iRow) = oDir.GetDetailsOf(sFile, 3)
                ActiveSheet.Range("G" & iRow) = oDir.GetDetailsOf(sFile, 4)
                ActiveSheet.Range("H" & iRow) = oDir.GetDetailsOf(sFile, 12)
                ActiveSheet.Range("I" & iRow) = oDir.GetDetailsOf(sFile, 209)
                ActiveSheet.Range("J" & iRow) = oDir.GetDetailsOf(sFile, 27)
                ActiveSheet.Range("K" & iRow) = oDir.GetDetailsOf(sFile, 316)
                ActiveSheet.Range("L" & iRow) = oDir.GetDetailsOf(sFile, 317)
                ActiveSheet.Range("M" & iRow) = oDir.GetDetailsOf(sFile, 315)
                ActiveSheet.Range("N" & iRow) = oDir.GetDetailsOf(sFile, 320)
                ActiveSheet.Range("O" & iRow) = oDir.GetDetailsOf(sFile, 321)
                ActiveSheet.Range("P" & iRow) = oDir.GetDetailsOf(sFile, 28)
                ActiveSheet.Range("Q" & iRow) = oDir.GetDetailsOf(sFile, 319)
                ActiveSheet.Range("R" & iRow) = oDir.GetDetailsOf(sFile, 31)
                ActiveSheet.Range("S" & iRow) = oDir.GetDetailsOf(sFile, 177)
                ActiveSheet.Range("T" & iRow) = oDir.GetDetailsOf(sFile, 179)
                ActiveSheet.Range("U" & iRow) = oDir.GetDetailsOf(sFile, 176)
                ActiveSheet.Range("V" & iRow) = oDir.GetDetailsOf(sFile, 178)
                ActiveSheet.Range("W" & iRow) = oDir.GetDetailsOf(sFile, 175)
                ActiveSheet.Range("X" & iRow) = oDir.GetDetailsOf(sFile, 271)
                
            End If
        Next
        
    MsgBox "Process Completed"
End Sub

**snb** · 05-26-2020, 03:21 AM

Restrict the writing into the worksheet to once.

Thread: Master file detail list

Thread Tools

Display

Master file detail list

Tags for this Thread

Posting Permissions