'Force the explicit declaration of variables
Option Explicit
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2017-Oct-28 Initial Release
' 2 2017-Oct-28 Enter the folder name
' 3 2017-Oct-29 Use File Dialog
' 4 2022-Dec-11 Copy Sheet
' 5 2022-Dec-12 Add DateCreated
' 6 2022-Dec-26 addRow, setRowCnt
' 7 2022-Dec-28 Add one line of summary for statistics
' 8 2023-Jan-10 Format month and day(date)
' 9 2023-Jan-19 Total File Size, walkaround for the compile error of format(date, "mm")
' **************************************************************************************
Sub ListFiles()
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)
'Declare the variables
Dim objFSO As FileSystemObject
Dim objFolder As Folder
Dim objFile As File
Dim strPath As String
Dim strFile As String
Dim NextRow As Long
Dim dblFileSize As Double
Dim dblFileTotalSize As Double
'Added Codes Begin
Dim Msg As String
Call clearContents
'Open the file dialog
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
'MsgBox (.SelectedItems(1))
strPath = .SelectedItems(1)
Else
Exit Sub
End If
End With
'Msg = "Write down the folder name, please: " & vbCr
'Msg = Msg & "e.g. C:\Users\Steve\Documents\Vids\"
'strPath = Trim(InputBox(Msg, "Input"))
If right(strPath, 1) <> "\" Then strPath = strPath & "\"
'Added Codes End
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder
Set objFolder = objFSO.GetFolder(strPath)
'If the folder does not contain files, exit the sub
If objFolder.Files.Count = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If
'Turn off screen updating
Application.ScreenUpdating = False
'Insert the headers for Columns A, B, C, and D
Cells(1, "A").Value = "File Name"
Cells(1, "B").Value = "Path"
Cells(1, "C").Value = "Size"
Cells(1, "D").Value = "Created Date"
'Find the next available row
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
'Loop through each file in the folder
For Each objFile In objFolder.Files
'List the name, size, and date/time of the current file
Cells(NextRow, 1).Value = objFile.Name
'Cells(NextRow, 2).Value = objFile.Path
Cells(NextRow, 2).Value = objFile.ParentFolder
'Cells(NextRow, 3).Value = objFile.Size
dblFileSize = objFile.Size
Cells(NextRow, 3).Value = dblFileSize
'Cells(NextRow, 3).Value = format(Round(dblFileSize / 1000000, 0), "#,#") & " MB" 'Format(n, "#,#")
Cells(NextRow, 4).Value = objFile.DateCreated
'Determine the next row
NextRow = NextRow + 1
dblFileTotalSize = dblFileTotalSize + dblFileSize
Next objFile
'Change the width of the columns to achieve the best fit
'Columns.AutoFit
'Format Cells
Range(Cells(2, 3), Cells(Rows.Count, "D").End(xlUp)).Select
Selection.HorizontalAlignment = xlRight
Range(Cells(2, 4), Cells(Rows.Count, "D").End(xlUp)).Select
Selection.NumberFormatLocal = "yyyy-mm-dd hh:mm"
Selection.HorizontalAlignment = xlCenter
Range("A1").Select
Call copySheet
Dim searchCnt As Long
Dim Cell As Range
For Each Cell In ActiveSheet.UsedRange.Columns(1).Cells
If InStr(Cell.Value, "_error_") > 0 Then
searchCnt = searchCnt + 1
End If
Next Cell
'MsgBox "searchCnt = " & searchCnt
Call addRow
Call addFilter
Call setRowCnt(searchCnt, dblFileTotalSize)
Range("A1").Select
'Turn screen updating back on
Application.ScreenUpdating = True
End Sub
Private Sub clearContents()
Worksheets("listFiles").Range("A1").EntireColumn.EntireRow.clearContents
End Sub
Private Sub copySheet()
'Sheets(1).Copy after:=Sheets(1)
Sheets(1).Copy after:=Sheets(ActiveWorkbook.Sheets.Count)
'Remove Buttons
Dim I As Long
Dim xOLE As Object
ActiveSheet.Buttons.Delete
For Each xOLE In ActiveSheet.OLEObjects
If TypeName(xOLE.Object) = "CommandButton" Then
xOLE.Delete
End If
Next
Dim n As Integer
Dim shtName As String
Dim dtToday As Date
Dim sMonth As String
'MsgBox (Year(Date) & Month(Date) & Day(Date))
'shtName = "List_" & Year(Date) & Month(Date) & Day(Date)
dtToday = Date
sMonth = Month(dtToday)
If Len(sMonth) = 1 Then
sMonth = "0" & sMonth
End If
'shtName = "List_" & Year(dtToday) & format(dtToday, "mm") & format(dtToday, "dd")
shtName = "List_" & Year(dtToday) & sMonth & format(dtToday, "dd")
'Format(Now, "yyyy/mm/dd/hh/mm/ss")
'dtToday = Now
'shtName = "List_" & Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now)
'shtName = "List_" & Year(dtToday) & Month(dtToday) & Day(dtToday) & Hour(dtToday) & Minute(dtToday) & Second(dtToday)
'shtName = "List_" & Year(dtToday) & format(dtToday, "mm") & Day(dtToday) & Hour(dtToday) & Minute(dtToday) & Second(dtToday)
Do While (shCheck(shtName))
shtName = shtName & " (2)"
'shtName = Replace(shtName, "_", "")
Loop
'Sheets(2).Name = shtName
ActiveSheet.Name = shtName
End Sub
' 해당시트가 있으면 True를, 그렇지 않으면 False 를 반환합니다
Private Function shCheck(shName$) As Boolean
On Error GoTo ec1
If CBool(Len(Sheets(shName$).Name)) Then shCheck = True
Exit Function
ec1:
shCheck = False
End Function
Private Sub addRow()
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
Private Sub addFilter()
Range("A2:D2").Select
Selection.AutoFilter
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
Range("B3").Select
ActiveWindow.FreezePanes = True
'Range("A1").Select
End Sub
Private Sub setRowCnt(ByVal searchCnt As Long, ByVal dblFileTotalSize As Double)
'MsgBox "searchCnt = " & searchCnt
Dim rowCnt As Long
rowCnt = Range("a3", Range("a2").End(xlDown)).Rows.Count
rowCnt = rowCnt - searchCnt
Cells(1, 1) = "Number of Working Games"
Cells(1, 2) = rowCnt
Cells(1, 3) = "Excluded"
Cells(1, 4) = searchCnt
Cells(1, 5) = "Total Size"
If (dblFileTotalSize > 1000000000) Then
Cells(1, 6) = format(Round(dblFileTotalSize / 1000000000, 0), "#,#") & " GB" 'Format(n, "#,#")
Else
Cells(1, 6) = dblFileTotalSize
End If
Range("A1").Select
Selection.HorizontalAlignment = xlCenter
Range("C1").Select
Selection.HorizontalAlignment = xlCenter
Columns("E:E").EntireColumn.AutoFit
Range("E1").Select
Selection.HorizontalAlignment = xlCenter
Columns("F:F").EntireColumn.AutoFit
Range("F1").Select
Selection.Style = "Comma [0]"
End Sub
