Posts by India VSM

Option Explicit


Sub ListFiles()
    Dim sPath      As String




    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select directory"
        .InitialFileName = ThisWorkbook.Path & "\"
        .AllowMultiSelect = False
        If .Show = 0 Then Exit Sub
        sPath = .SelectedItems(1) & "\"
    End With




    NoCursing sPath, Range("A1")
End Sub




Sub NoCursing(ByVal sPath As String, rOut As Range)
    ' lists file name, size, and date for the files in and below sPath
   ' in columns A:C of rOut




    ' attribute mask
   Const iAttr    As Long = vbNormal + vbReadOnly + vbSystem + vbDirectory
    Dim jAttr      As Long        ' file attributes
   Dim col        As Collection  ' queued directories
   Dim iFile      As Long        ' file counter
   Dim sFile      As String      ' file name
   Dim sName      As String      ' full file name
   Dim fSec        As Single      ' seconds since midnight




    Dim maxRows As Long
    Dim sheetNumber As Integer
    maxRows = 1048576
    sheetNumber = 1
    iFile = 1




    With rOut.Range("A1:C1").Resize(rOut.Worksheet.Rows.Count - rOut.Row + 1)
        .ClearContents
        .Rows(1).Value = Split("File,Date,Size", ",")
    End With




    Application.ScreenUpdating = False
    fSec = Timer




    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    Set col = New Collection
    col.Add sPath




    Do While col.Count
        sPath = col(1)
On Error Resume Next
        sFile = Dir(sPath, iAttr)




        Do While Len(sFile)
            sName = sPath & sFile




            On Error Resume Next
            jAttr = GetAttr(sName)




            If Err.Number Then
                ' You can't get attributes for files with Unicode characters in
               ' the name, or some particular files (e.g., "C:\System Volume Information")
               Debug.Print sName
                Err.Clear




            Else
                On Error GoTo 0
                If jAttr And vbDirectory Then
                    If Right(sName, 1) <> "." Then col.Add sName & "\"




                Else
                    iFile = iFile + 1
                    If (iFile And &H3FF) = 0 Then
                        Application.StatusBar = sMsg(iFile, Timer - fSec, col.Count)
                        DoEvents
                    End If
                   
                    If iFile = maxRows Then
                      sheetNumber = sheetNumber + 1
                      ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
                      ActiveSheet.Name = "Sheet-" & sheetNumber
                    End If




                  iFile = iFile + 1
                   
                    rOut.Range("A1:C1").Offset(iFile).Value = Array(sName, _
                                                                    FileDateTime(sName), _
                                                                    FileLen(sName))
                End If
            End If
            sFile = Dir()
        Loop
        col.Remove 1
    Loop




    iFile = iFile + 1
    rOut.Offset(iFile).Value = sMsg(iFile - 1, Timer - fSec, col.Count)
    rOut.CurrentRegion.Sort Key1:=rOut.Range("A1"), Header:=xlYes
    Columns.AutoFit
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub




Function sMsg(nFile As Long, fSec As Single, nCol As Long) As String
    sMsg = "  Files listed: " & Format(nFile, "#,##0") & _
          "  ET: " & Format(fSec / 86400, "h:mm:ss") & _
          "  Files/s: " & Format(nFile / fSec, "0") & _
          "  Directories queued: " & nCol
End Function

'Force the explicit delcaration of variables
 Option Explicit




 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 Scripting.FileSystemObject
 Dim objTopFolder As Scripting.Folder
 Dim strTopFolderName As String
 Dim n As Long
 Dim Msg As Byte
 Dim Drilldown As Boolean








 'Assign the top folder to a variable
 With Application.FileDialog(msoFileDialogFolderPicker)
 .AllowMultiSelect = False
 .Title = "Pick a folder"
 .Show
 If .SelectedItems.Count = 0 Then MsgBox "Operation Cancelled by the user",     vbExclamation + vbOKOnly, "List Files": Exit Sub
strTopFolderName = .SelectedItems(1)




    Msg = MsgBox("Do you want to list all files in descendant folders,  too?", _
    vbInformation + vbYesNo, "Drill-Down")
    If Msg = vbYes Then Drilldown = True Else Drilldown = False
  End With




' create a new sheet
 If Len(Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1)) < 31    Then
 ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name =    Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1)
Else: ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name =   Left(Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1), 31)
End If
'Insert the headers for Columns A through F
Range("A1").Value = "File Name"
Range("B1").Value = "Ext"
Range("C1").Value = "File Name"
Range("D1").Value = "File Size"
Range("E1").Value = "File Type"
Range("F1").Value = "Date Created"
Range("G1").Value = "Date Last Accessed"
Range("H1").Value = "Date Last Modified"
Range("I1").Value = "File Path"








'Create an instance of the FileSystemObject
 Set objFSO = CreateObject("Scripting.FileSystemObject")




'Get the top folder
 Set objTopFolder = objFSO.GetFolder(strTopFolderName)




'Call the RecursiveFolder routine
 Call RecursiveFolder(objTopFolder, Drilldown)




'Change the width of the columns to achieve the best fit
'Columns.AutoFit




'ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).TableStyle = "TableStyleLight1"
MsgBox ("Done")
ActiveWorkbook.Save
Sheet1.Activate
End Sub




Sub RecursiveFolder(objFolder As Scripting.Folder, _
IncludeSubFolders As Boolean)




'Declare the variables
 Dim objFile As Scripting.File
 Dim objSubFolder As Scripting.Folder
 Dim NextRow As Long
 Dim strTopFolderName As String
 Dim n As Long
 Dim maxRows As Long
 Dim sheetNumber As Integer
 maxRows = 1048576




'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
    'to take complete filename in column C  and extract filename without  extension lso allowing for fullstops in filename itself
    Cells(NextRow, "A") =    "=LEFT(RC[+2],FIND(""#"",SUBSTITUTE(RC[+2],""."",""#"",LEN(RC[+2])- LEN(SUBSTITUTE(RC[+2],""."",""""))))-1)"








    'to take complete filename from row C and show only its extension
    Cells(NextRow, "B") = "=TRIM(RIGHT(SUBSTITUTE(RC[+1],""."",REPT(""  "",LEN(RC[+1]))),LEN(RC[+1])))"








    Cells(NextRow, "C").Value = objFile.Name
    Cells(NextRow, "D").Value = Format((objFile.Size / 1024), "000") & " KB"
    Cells(NextRow, "E").Value = objFile.Type
    Cells(NextRow, "F").Value = objFile.DateCreated
    Cells(NextRow, "G").Value = objFile.DateLastAccessed
    Cells(NextRow, "H").Value = objFile.DateLastModified
    Cells(NextRow, "I").Value = objFile.Path












    NextRow = NextRow + 1
Next objFile




' If "descendant" folders also get their files listed, then sub calls itself recursively




 If IncludeSubFolders Then
    For Each objSubFolder In objFolder.SubFolders
        Call RecursiveFolder(objSubFolder, True)
    Next objSubFolder
End If




'Loop through files in the subfolders




'If IncludeSubFolders Then
 '   For Each objSubFolder In objFolder.SubFolders
  '  If Msg = vbYes Then Drilldown = True Else Drilldown = False
   '     Call RecursiveFolder(objSubFolder, True)
    'Next objSubFolder
'End If




 If n = maxRows Then
 sheetNumber = sheetNumber + 1
 ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
 'ActiveSheet.Name = "Sheet-" & sheetNumber
 ActiveSheet.Name = strTopFolderName & "_" & sheetNumber
 n = 0
 End If
 n = n + 1
 End Sub

Sub ListFiles()
Const sRoot     As String = "C:\"
Dim t As Date




Application.ScreenUpdating = False
With Columns("A:C")
    .ClearContents
    .Rows(1).Value = Split("File,Date,Size", ",")
End With




t = Timer
NoCursing sRoot
Columns.AutoFit
Application.ScreenUpdating = True
MsgBox Format(Timer - t, "0.0s")
End Sub




Sub NoCursing(ByVal sPath As String)
Const iAttr     As Long = vbNormal + vbReadOnly + _
      vbHidden + vbSystem + _
      vbDirectory
Dim col         As Collection
Dim iRow        As Long
Dim jAttr       As Long
Dim sFile       As String
Dim sName       As String




If Right(sPath, 1) <> "\" Then sPath = sPath & "\"




Set col = New Collection
col.Add sPath




iRow = 1




Do While col.Count
    sPath = col(1)




    sFile = Dir(sPath, iAttr)




    Do While Len(sFile)
        sName = sPath & sFile




        On Error Resume Next
        jAttr = GetAttr(sName)
        If Err.Number Then
            Debug.Print sName
            Err.Clear




        Else
            If jAttr And vbDirectory Then
                If Right(sName, 1) <> "." Then col.Add sName & "\"
            Else
                iRow = iRow + 1
                If (iRow And &H3FF) = 0 Then Debug.Print iRow
                Rows(iRow).Range("A1:C1").Value = Array(sName, _
                                                        FileLen(sName), _
                                                        FileDateTime(sName))
            End If
        End If
        sFile = Dir()
    Loop
    col.Remove 1
Loop
End Sub