-
1 Attachment(s)
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.
-
2 Attachment(s)
.
To simplify matters .. here are two examples for you to review. Providing code here for one of the workbooks :
Code:
' ----------------------------------------------------------------------------------------------------------------------------------' 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
-
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
Code:
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
Code:
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
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!
-
1 Attachment(s)
Updated file as per above. Couldn't figure out how to update my original post. Thanks
-
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.
Code:
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
-
Restrict the writing into the worksheet to once.
