Delete files based on last date accessed (or similar)

[marts2003]

Hi there,

A while back I came across the code given below (not my own work, but I'm afraid I can't remember exactly where it came from - although it might be Chip Pearson or Ron de Bruin). It works really well, but I now have a slightly different requirement.

Is it possible to modify this so that it only deletes files that are older than a certain number of years? Ideally, I want to use this to delete files that have not been accessed in the last 5 years - so that I only retain files that have been used more recently than that.

Many thanks for any suggestions or advice!



Private myFiles() As String
Private Fnum As Long


Sub File_Killer_That_Deletes_txt_Files()
Dim myCountOfFiles As Long
Dim oApp As Object
Dim oFolder As Variant
Dim I As Long


Set oApp = CreateObject("Shell.Application")


'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder", 512)
If Not oFolder Is Nothing Then


myCountOfFiles = Get_File_Names( _
MyPath:=oFolder.Self.Path, _
Subfolders:=True, _
ExtStr:="*.txt")


If myCountOfFiles = 0 Then
MsgBox "No files that match the ExtStr in this folder"
Exit Sub
End If


For I = LBound(myFiles) To UBound(myFiles)
On Error Resume Next
Kill myFiles(I)
On Error GoTo 0
Next I


End If


End Sub




Function Get_File_Names(MyPath As String, Subfolders As Boolean, _
ExtStr As String) As Long


Dim Fsbj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object


'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "" Then
MyPath = MyPath & ""
End If


'Create FileSystemObject object
Set Fsbj = CreateObject("Scripting.FileSystemObject")


Erase myFiles()
Fnum = 0


'Test if the folder exist and set RootFolder
If Fsbj.FolderExists(MyPath) = False Then
Exit Function
End If
Set RootFolder = Fsbj.GetFolder(MyPath)


'Fill the array(myFiles)with the list of Excel files in the folder(s)
'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(file.Name) Like LCase(ExtStr) Then
Fnum = Fnum + 1
ReDim Preserve myFiles(1 To Fnum)
myFiles(Fnum) = MyPath & file.Name
End If
Next file


'Loop through the files in the Sub Folders if SubFolders = True
If Subfolders Then
Call ListFilesInSubfolders(OfFolder:=RootFolder, FileExt:=ExtStr)
End If


Get_File_Names = Fnum
End Function





Sub ListFilesInSubfolders(OfFolder As Object, FileExt As String)


Dim SubFolder As Object
Dim fileInSubfolder As Object


For Each SubFolder In OfFolder.Subfolders
ListFilesInSubfolders OfFolder:=SubFolder, FileExt:=FileExt


For Each fileInSubfolder In SubFolder.Files
If LCase(fileInSubfolder.Name) Like LCase(FileExt) Then
Fnum = Fnum + 1
ReDim Preserve myFiles(1 To Fnum)
myFiles(Fnum) = SubFolder & "" & fileInSubfolder.Name
End If
Next fileInSubfolder


Next SubFolder
End Sub

 

[marts2003]

Re: How to delete files based on last date accessed (or similar)

Sorted.

Just needed to modify the last Sub:

'Add in
Dim d As Date
d = Date


'Amend
If LCase(fileInSubfolder.Name) Like LCase(FileExt) And _
d - fileInSubfolder.DateLastModified < 365 Then


and can use < or >, depending on the date range required.

Hope this helps somebody!