Consulting

Results 1 to 6 of 6

Thread: Master file detail list

  1. #1
    VBAX Newbie
    Joined
    May 2020
    Posts
    4
    Location

    Master file detail list

    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.
    Attached Files Attached Files

  2. #2
    VBAX Mentor Logit's Avatar
    Joined
    Sep 2016
    Posts
    479
    Location
    .
    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

  3. #3
    VBAX Newbie
    Joined
    May 2020
    Posts
    4
    Location
    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!

  4. #4
    VBAX Newbie
    Joined
    May 2020
    Posts
    4
    Location
    Updated file as per above. Couldn't figure out how to update my original post. Thanks
    Attached Files Attached Files

  5. #5
    VBAX Newbie
    Joined
    May 2020
    Posts
    4
    Location
    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

  6. #6
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,857
    Restrict the writing into the worksheet to once.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •