File Analysis Tool

[MOTOWN44]

Afternoon All
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
I have a problem which I think is quite complex but I could be wrong. I have a excel spreadsheet with the following code on
<o> </o>
<o>

<o:p>Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
 
Sub MainExtractData()
     
    Dim NewSht As Worksheet
    Dim MainFolderName As String
     
    ReDim X(1 To 65533, 1 To 11)
    
    Set objShell = CreateObject("Shell.Application")
    TimeLimit = 0
    StartTime = Timer
    
    'Application.ScreenUpdating = False
    'For Browser Window MainFolderName = BrowseForFolder
    MainFolderName = Range("B1") & "\"
    Set NewSht = ThisWorkbook.Sheets.Add
     
    X(1, 1) = "Path"
    X(1, 2) = "File Name"
    X(1, 3) = "Type"
    X(1, 4) = "Last Modified"
    X(1, 5) = "Created"
    X(1, 6) = "Last Accessed"
    X(1, 7) = "Size"
    X(1, 8) = "Owner"
    X(1, 9) = "Author"
    X(1, 10) = "Title"
    X(1, 11) = "Comments"
    
    i = 1
     
    Set FSO = CreateObject("scripting.FileSystemObject")
    Set oFolder = FSO.GetFolder(MainFolderName)
    
    On Error Resume Next
    
    For Each Fil In oFolder.Files
    
        Set objFolder = objShell.Namespace(oFolder.Path)
        Set objFolderItem = objFolder.ParseName(Fil.Name)
        
        i = i + 1</o:p>
<o:p></o:p> 
<o:p>'**TEST CODE HERE**</o:p>
<o:p></o:p> 
<o:p>            If i = 20 Then</o:p>
<o:p>            Worksheets.Add</o:p>
<o:p>            End If</o:p>
<o:p></o:p> 
<o:p>'**TEST CODE ENDS**
</o:p>
<o:p>        If i Mod 1 = 0 Then</o:p>
<o:p></o:p> 
<o:p>            Application.StatusBar = "Processing File " & i
            DoEvents
            
        End If
        
        X(i, 1) = oFolder.Path
        X(i, 2) = Fil.Name
        X(i, 3) = Fil.Type
        X(i, 4) = Fil.DateLastModified
        X(i, 5) = Fil.DateCreated
        X(i, 6) = Fil.DateLastAccessed
        X(i, 7) = Fil.Size
        X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
        X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
        X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
        X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
            
    Next
     
     'Subfolder Code</o:p>
<o:p>    If TimeLimit = 0 Then
    
        Call RecursiveFolder(oFolder, 0)
        
    Else
    
        If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
        
    End If</o:p>
<o:p>FastExit:
    Range("A:K") = X
    If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
    Range("A:K").WrapText = False
    Range("A:K").EntireColumn.AutoFit
    Range("1:1").Font.Bold = True
    Rows("2:2").Select
    'ActiveWindow.FreezePanes = True
    Range("a1").Activate
     
    Set FSO = Nothing
    Set objShell = Nothing
    Set oFolder = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
    Set Fil = Nothing
    Application.StatusBar = ""
    'Application.ScreenUpdating = True
    
End Sub</o:p>

</o><o> </o>
<o></o>
<o><o>The next bit refers to recursive folders this is for the subfolders - ive included it incase it also needs amending but im pretty sure its the first block of code that needs amending</o>
<o></o>
<o>

<o:p>Sub RecursiveFolder(xFolder, TimeTest As Long)</o:p>
<o:p>    Dim SubFld
    
    For Each SubFld In xFolder.SubFolders
    
        Set oFolder = FSO.GetFolder(SubFld)
        Set objFolder = objShell.Namespace(SubFld.Path)
        
        For Each Fil In SubFld.Files
        
            Set objFolder = objShell.Namespace(oFolder.Path)
            
            If Not objFolder Is Nothing Then
            
                Set objFolderItem = objFolder.ParseName(Fil.Name)
                
                i = i + 1
                
                If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
                
                    Exit Sub
                    
                End If
                
                If i Mod 1 = 0 Then
                
                    Application.StatusBar = "Processing File " & i
                    DoEvents
                    
                End If
                
                X(i, 1) = SubFld.Path
                X(i, 2) = Fil.Name
                X(i, 3) = Fil.Type
                X(i, 4) = Fil.DateLastModified
                X(i, 5) = Fil.DateCreated
                X(i, 6) = Fil.DateLastAccessed
                X(i, 7) = Fil.Size
                X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
                X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
                X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
                X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
                
            Else
            
                Debug.Print Fil.Path & " " & Fil.Name
                
            End If
            
        Next
        
        Call RecursiveFolder(SubFld, TimeTest)
        
    Next
    
End Sub</o:p>

</o></o><o></o>
Basically what it does it look at the target file (path defined in Cell B2) and lists the Path Name Size Author etc of every file in the target folder and its sub folders.
<o> </o>
This has been working perfectly except now I have to analyse a folder that has more files that excel has rows…
<o> </o>
I've been toying with an if statement at the start of the Looped part (I've marked it on the code above as **TEST CODE HERE**) of the code along the lines of
<o> </o>

If I = 65533 then
<o:p> </o:p>
Worksheet.add
<o:p> </o:p>
I = 2
<o:p> </o:p>
End if

<o> </o>
<o></o>
But all this does is create new blank sheets and sticks 65533 lines of info on the last sheet created, instead of filling sheet 1 with 65533 lines of info and continuing on from that point on sheet 2 then sheet 3 etc
<o> </o>
I cant get my head round how to make this work I've been toying with my X definition and I definition but both have similar outcomes
<o> </o>
I don't know if there is a quick fix or if the code needs pretty much re-writing (god I hope not) but your help would be much appreciated.
<o></o>
Thank you

 

[iliace]

After you add the new sheet and set I = 2 (note that your TEST CODE doesn't do that as you pasted it), also do another ReDim on your X - that will clear info you already have in there.

 

[MOTOWN44]

Thanks for getting back to me.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
I added the ReDim of X in to the if statement as you suggested but its still giving me blank sheets when I = 20 but putting all the file info on the last sheet.
<o> </o>
I think the actual file info is being stored somewhere in a recordset and then been dumped in as one big lump of information. If you F8 through the code even after the first but where it adds the column headers nothing actually appears till the loop is finished!
<o> </o>
I just cant get my head round this!

 

[iliace]

What it's doing is storing all the information it retrieves into an array, then writes it at the end. I looked at the code more closely and made some modifications that will do what you want. I don't generally use FSO and Shell scripting, and this code is working very slowly for me - is this also the case for you?

Anyway, I'm highlighting changes in bold red. This entire code also replaces the recursive subfolder function. Post back with questions, etc.

Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
Public NewSht As Excel.Worksheet

Const ItemsPerSheet As Long = 500
 
Sub MainExtractData()
    Dim MainFolderName As String
    
    Dim TimeLimit As Long
    Dim StartTime As Long
     
    Set objShell = CreateObject("Shell.Application")
    TimeLimit = 0
    StartTime = Timer
    
    'Application.ScreenUpdating = False
    'For Browser Window MainFolderName = BrowseForFolder
    MainFolderName = ActiveSheet.Range("B1") & "\"
    Set NewSht = ThisWorkbook.Sheets.Add

    ResetX

    i = 1

    Set FSO = CreateObject("scripting.FileSystemObject")
    Set oFolder = FSO.GetFolder(MainFolderName)

    On Error Resume Next

    For Each Fil In oFolder.Files
        Set objFolder = objShell.Namespace(oFolder.Path)
        Set objFolderItem = objFolder.ParseName(Fil.Name)
        
        i = i + 1

'**TEST CODE HERE**
 
        If i = ItemsPerSheet Then
          Call WriteToSheet(NewSht)
          Set NewSht = Worksheets.Add
          ResetX
          i = 2
        End If
 
'**TEST CODE ENDS**

        If i Mod 100 = 0 Then
            Application.StatusBar = "Processing File " & i
            DoEvents
        End If
        
        X(i, 1) = oFolder.Path
        X(i, 2) = Fil.Name
        X(i, 3) = Fil.Type
        X(i, 4) = Fil.DateLastModified
        X(i, 5) = Fil.DateCreated
        X(i, 6) = Fil.DateLastAccessed
        X(i, 7) = Fil.Size
        X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
        X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
        X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
        X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
    Next
    
     'Subfolder Code
    If TimeLimit = 0 Then
        Call RecursiveFolder(oFolder, 0)
    Else
        If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
    End If

FastExit:
  Call WriteToSheet(NewSht)

  Set FSO = Nothing
  Set objShell = Nothing
  Set oFolder = Nothing
  Set objFolder = Nothing
  Set objFolderItem = Nothing
  Set Fil = Nothing
  Application.StatusBar = ""
  Application.ScreenUpdating = True
End Sub

Sub ResetX()
  ReDim X(1 To ItemsPerSheet, 1 To 11)
  
    X(1, 1) = "Path"
    X(1, 2) = "File Name"
    X(1, 3) = "Type"
    X(1, 4) = "Last Modified"
    X(1, 5) = "Created"
    X(1, 6) = "Last Accessed"
    X(1, 7) = "Size"
    X(1, 8) = "Owner"
    X(1, 9) = "Author"
    X(1, 10) = "Title"
    X(1, 11) = "Comments"
End Sub


Sub WriteToSheet(wsh As Excel.Worksheet)
  With wsh
    .Range("A1").Resize(i, UBound(X, 2)) = X
    .Range("A:K").WrapText = False
    .Range("A:K").EntireColumn.AutoFit
    .Range("1:1").Font.Bold = True
  End With
End Sub

Sub RecursiveFolder(xFolder, TimeTest As Long)
    Dim SubFld

    For Each SubFld In xFolder.SubFolders
        Set oFolder = FSO.GetFolder(SubFld)
        Set objFolder = objShell.Namespace(SubFld.Path)

        For Each Fil In SubFld.Files
            Set objFolder = objShell.Namespace(oFolder.Path)

            If Not objFolder Is Nothing Then
                Set objFolderItem = objFolder.ParseName(Fil.Name)
                i = i + 1

                If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
                    Exit Sub
                End If

                If i Mod 100 = 0 Then
                    Application.StatusBar = "Processing File " & i
                    DoEvents
                End If

                If i = ItemsPerSheet Then
                  Call WriteToSheet(NewSht)
                  Set NewSht = Worksheets.Add
                  ResetX
                  i = 2
                End If

                X(i, 1) = SubFld.Path
                X(i, 2) = Fil.Name
                X(i, 3) = Fil.Type
                X(i, 4) = Fil.DateLastModified
                X(i, 5) = Fil.DateCreated
                X(i, 6) = Fil.DateLastAccessed
                X(i, 7) = Fil.Size
                X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
                X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
                X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
                X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
            Else
                Debug.Print Fil.Path & " " & Fil.Name
            End If
        Next
        Call RecursiveFolder(SubFld, TimeTest)
    Next
End Sub

 

[iliace]

Note, the ItemsPerSheet constant at the top determines when the code goes to the next sheet. I did 500 for my test, yours was at 20, and it sounds like eventually you'll want it at 65,535.