Need help with File System Object code.

S

Simi

New member
Joined
Feb 10, 2012
Messages
190
Reaction score
0
Points
0
Location
Utah, USA
Excel Version(s)
Version 2002 Build 12527.20194
I am trying to clean up some files and need some help with using the File System Object and going through folders.
I have tried using some counters to figure out how many files I am trying to copy, but I seem to be error-ing out before it runs on all the folders/files.

Can someone please help with where I am missing something.

Code: 
Private Sub Consolidate(strFolder As String, wbMaster As Workbook)
    
    Dim objFso As Object
    Dim objFiles As Object
    Dim objSubFolder As Object
    Dim objSubFolders As Object
    Dim objFile As Object
    Dim ary(3) As Variant
    Dim lRow As Long
    Dim sFolder As String
    'Set Error Handling
    On Error GoTo EarlyExit
    Dim lCounter As Long


    'Create objects to enumerate files and folders
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objFiles = objFso.getfolder(strFolder).Files
    Set objSubFolders = objFso.getfolder(strFolder).subFolders
    
lRow = 1
lCounter = 0


Set objFiles = objFso.getfolder(strFolder).Files
For Each objFile In objFiles
    With ActiveSheet
        If objFile.datelastmodified > .Range("I1") Then
            .Range("A" & lRow) = objFile.Path
            .Range("C" & lRow) = objFile.datelastmodified
            sFolder = Left(objFile.Path, Len(objFile.Path) - Len(objFile.Name) - 1)
            sFolder = "T" & Right(sFolder, Len(sFolder) - 1)
            Range("B" & lRow) = sFolder
            'sFolder = Left(objFile.Path, Len(objFile.Path) - Len(objFile.Name))
            '.Range("D" & lRow) = sFolder
            If FileFolderExists(sFolder & "") Then
                'folder exists
            Else
                'create the folder
                objFso.createfolder (sFolder & "\")
            End If
            
            sFolder = sFolder & "\"
            objFile.Copy sFolder
            lRow = lRow + 1
        End If
        .Range("I2") = .Range("I2") + 1
    End With


    lCounter = lCounter + 1
Next objFile


'Go in sub folders and continue.
    For Each objSubFolder In objSubFolders
        Consolidate objSubFolder.Path, wbMaster
    Next objSubFolder


With ActiveSheet
    .Range("I3") = lCounter
End With


EarlyExit:
    'Clean up
    On Error Resume Next
    Set objFile = Nothing
    Set objFiles = Nothing
    Set objFso = Nothing
    On Error GoTo 0
End Sub
 
I think one problem could be:

objFso.createfolder (sFolder & "\")

I think this only adds one subfolder to an existing folder and if the path doesn't exist up to the penultimate folder, it errors.
Since you're using recursion, it could be that some subfolders contain no files after the date in I1, so recursion moves on without creating the intermediate folders. If a file is encountered which has a date after the date in I1 the createfolder will fail.
I haven't dreamt up a solution yet but it would involve testing for the folders in the path one by one and creating them if needed. If I get time I'll look at this.

Taking out the On Error line during development helps in debugging.
 
Oh that was a really great idea p45cal. I am going to change it to create a duplicate folder structure as it goes and not have the folder creation as part of the date check. That should help with my problem. I was worried when I ran this because it worked really well on the sample data I was using, but when I ran it on my main folder it didn't check all the files. It ran some 160,000 files but there are 250,000+ files that needed to be checked.

I will post back if I get better results.
 
The following worked here without the On Error line being active.
Code: 
Private Sub Consolidate(strFolder As String, wbMaster As Workbook)
Dim objFso As Object
Dim objFiles As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim objFile As Object
Dim ary(3) As Variant
Dim lRow As Long
Dim sFolder As String
'Set Error Handling
'On Error GoTo EarlyExit
Dim lCounter As Long

'Create objects to enumerate files and folders
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.getfolder(strFolder).Files
Set objSubFolders = objFso.getfolder(strFolder).subFolders

'lRow = 1
lCounter = 0

Set xxx = objFso.getfolder(strFolder)
'If xxx.Attributes <> 16 Then Debug.Print xxx.Attributes
If xxx.Attributes <> 1046 Then 'skip folders like My Music, My Videos which are links
  Set objFiles = objFso.getfolder(strFolder).Files
  For Each objFile In objFiles
    With ActiveSheet
      If objFile.datelastmodified > .Range("I1") Then
      lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Range("A" & lRow) = objFile.Path
        .Range("C" & lRow) = objFile.datelastmodified
        sFolder = Left(objFile.Path, Len(objFile.Path) - Len(objFile.Name) - 1)
        .Range("B" & lRow) = sFolder
        sFolder = "T" & Right(sFolder, Len(sFolder) - 1)
        'objFso.CopyFile objFile.Path, Replace(objFile.parentfolder.Path, "C:\", "T:\")
        'sFolder = Left(objFile.Path, Len(objFile.Path) - Len(objFile.Name))
        .Range("D" & lRow) = sFolder
        If Not FileFolderExists(sFolder & "") Then CreateFolderStructureAsRequired "T", objFile, objFso
        sFolder = sFolder & "\"
        If objFile.Name <> "Outlook.pst" Then objFile.Copy sFolder
        'lRow = lRow + 1
      End If
      .Range("I2") = .Range("I2") + 1
    End With
    lCounter = lCounter + 1
  Next objFile
  'Go in sub folders and continue.
  For Each objSubFolder In objSubFolders
    Consolidate objSubFolder.Path, wbMaster
  Next objSubFolder
End If
ActiveSheet.Range("I3") = lCounter

EarlyExit:
'Clean up
On Error Resume Next
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing
On Error GoTo 0
End Sub

Code: 
Public Function FileFolderExists(strFullPath As String) As Boolean
'Author       : Ken Puls ([URL="http://www.excelguru.ca/"][COLOR=#0000ff]www.excelguru.ca[/COLOR][/URL])
'Macro Purpose: Check if a file or folder exists
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
Code: 
Sub CreateFolderStructureAsRequired(DestnDriveLetter, SourceFile, fso)
Dim myStrFolder As String
yy = Split(SourceFile.Path, Application.PathSeparator)
myStrFolder = DestnDriveLetter & ":" & Application.PathSeparator
For i = 1 To UBound(yy) - 1
  myStrFolder = myStrFolder & yy(i) & Application.PathSeparator
  If Not FileFolderExists(myStrFolder) Then fso.createfolder myStrFolder
Next i
End Sub
 
Well as an update I have changed this to duplicate the folder structure regardless of the file needing to be copied.
It seems to be working to duplicate the structure, I can't run it to copy my files yet, I have to wait until no one is here using the server.

this is what I changed it to.

Code: 
Private Sub Consolidate(strFolder As String, wbMaster As Workbook)
    
    Dim objFso As Object
    Dim objFiles As Object
    Dim objSubFolder As Object
    Dim objSubFolders As Object
    Dim objFile As Object
    Dim ary(3) As Variant
    Dim lRow As Long
    Dim sFolder As String
    'Set Error Handling
    On Error GoTo EarlyExit
    Dim lCounter As Long


    'Create objects to enumerate files and folders
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objFiles = objFso.getfolder(strFolder).Files
    Set objSubFolders = objFso.getfolder(strFolder).subFolders
With ActiveSheet
    lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
End With
lCounter = 0


Set objFiles = objFso.getfolder(strFolder).Files
For Each objFile In objFiles
Exit For 'testing folder creation only
    With ActiveSheet
        sFolder = Left(objFile.Path, Len(objFile.Path) - Len(objFile.Name) - 1)
        sFolder = "T" & Right(sFolder, Len(sFolder) - 1)
        If objFile.datelastmodified > .Range("I1") Then
            .Range("A" & lRow) = objFile.Path
            .Range("C" & lRow) = objFile.datelastmodified
            sFolder = sFolder & "\"
            objFile.Copy sFolder
            lRow = lRow + 1
        End If
        .Range("I2") = .Range("I2") + 1
    End With


    lCounter = lCounter + 1
Next objFile


'Go in sub folders and continue.
For Each objSubFolder In objSubFolders
    sFolder = objSubFolder.Path
    sFolder = "T" & Right(sFolder, Len(sFolder) - 1)   
    If FileFolderExists(sFolder & "") Then
        'folder exists
    Else
        'create the folder
        objFso.createfolder (sFolder & "\")
    End If
    Consolidate objSubFolder.Path, wbMaster
Next objSubFolder


With ActiveSheet
    .Range("I3") = lCounter
End With


EarlyExit:
    'Clean up
    On Error Resume Next
    Set objFile = Nothing
    Set objFiles = Nothing
    Set objFso = Nothing
    On Error GoTo 0
End Sub
 
Simi said:
Well as an update I have changed this to duplicate the folder structure regardless of the file needing to be copied.
Click to expand...
We seem to have posted at almost the same time. I've tried only to re-create the folders necessary, that way you're not for ever searching for files in empty folders.
After resolving the error caused by trying to create folders, another error cropped up being 'permission denied' to folders which were shortcuts or links, hence my:

If xxx.Attributes <> 1046 Then

but with that, no further errors were encountered.
 
Thank you p45cal, I wish I knew more about this type of coding.
I will try this tonight or tomorrow when no one else is using the server.
Thank you for the help.
 
Well, I ran into a problem while running your code.
I ended up trying to copy a file that I don't have permissions on.
Is there a way to skip those type of files?
but also, include those files in my list of files that were copied, with another note that it was permission denied.
 
Well we could for example do something similar to what I did with a line (which I shouldn't have left as is):
If objFile.Name <> "Outlook.pst" Then objFile.Copy sFolder
(It was because I was copying a huge .pst file which was slowing down my testing).
We'd need to establish whether it was the folder or the file that was denying you permissions.
This one was testing the folder:
If xxx.Attributes <> 1046 Then 'skip folders like My Music, My Videos which are links
So it's a matter of stepping through the code when the error is encountered and seeing what's different about the file/folder, so that we can note that it has not been copied etc.
Use the Locals pane to set and examine the properties of objects.

If you want we could do a TeamViewer session?
 
How do you know what number to use for the attributes line, the 1046?
Also, I have just re-enabled the on error line.
I also added a check to see how many folders are accessed.
I am now coming up with, this running on 252829 files in 15455 folders. My problem is there are 252903 files in 15472 folders.
I can't afford to be "missing" these files and folders.

Thank you again for your time and help on this issue p45cal.
 
Simi said:
How do you know what number to use for the attributes line, the 1046?
Click to expand...
See that commented out line?:
'If xxx.Attributes <> 16 Then Debug.Print xxx.Attributes
it was to help me debug; most of the folder attributes were 16 but I wanted to know the range of attributes values apart from 16. The Immediate pane showed me that. However, setting the folder object to xxx allowed me to step through code with F8 while looking at the properties of xxx in the Immediate pane to see what was different from a normal folder. I did a help on folder attributes and found out there what the values mean.
You'll probably need to do something similar with the file object. I can't do this for you here as clearly there are different kinds of file/folder from what I have here which is why I suggested a Teamviewer session.

Anyway, it's bedtime here for me now.
 
p45cal,

Thank you for all of your help with this project.
Instead of figuring out why I didn't have permissions, as I am in the administrator group, I simply log'd in with the actual administrator login then ran the code. It ran on all files and folders ;)

Please consider this problem as solved.
 
You must log in or register to reply here.
Back
Top