Public Function Delete_Folders()
On Error Resume Next
Dim FS As FileSystemObject ' Declares the File System Object
'Set the File System Object
Set FS = CreateObject("Scripting.FileSystemObject")
Dim dtmDate As Date 'Declare the dtmDate variable
Dim ImagePath 'Declare the ImagePath variable
Dim ImageFolder 'Declare the ImageFolder variable
Dim ImageFolderDate ' Declare the ImageFolderDate variable
Dim strDay 'Declare the strDay variable
Dim strMonth 'Declare the strMonth variable
Dim strYear 'Declare the strYear variable
'Get the current date - 6 months [182 days]
dtmDate = DateAdd("m", -6, Date)
'Get the folder names in J:\ that represent directories.
ImagePath = "J:\" 'Set the path to the Image Folders.
ImageFolder = Dir(ImagePath, vbDirectory) 'Retrieve the first entry.
Do While ImageFolder <> "" 'Start the loop.
'Ignore the current directory and the encompassing directory.
If ImageFolder <> "." And ImageFolder <> ".." Then
'Get the Name of the ImageFolder then
If (GetAttr(ImagePath & ImageFolder) And vbDirectory) = vbDirectory Then
strYear = Left(ImageFolder, 4) 'Get the left four characters of the ImageFolder Name
strMonth = Mid(ImageFolder, 5, 2) 'Get the 5th and 6th characters of the ImageFolder Name
strDay = Right(ImageFolder, 2) 'Get the 7th and 8th characters of the ImageFolder Name
'Convert the ImageFolderDate to true date data type
ImageFolderDate = CDate(strDay & "/" & strMonth & "/" & strYear)
'If the ImageFolderDate is equal to or less than the dtmDate variable then
If ImageFolderDate <= dtmDate Then
'Delete the Folder
[COLOR=red]FS.DeleteFolder (ImageFolder)
[/COLOR]
MsgBox "Folder " & ImageFolderDate & " Deleted"
End If
End If
End If
ImageFolder = Dir 'Get the next folder.
DoEvents
'Indicates in the progress bar the folder being worked on
DoCmd.Echo True, "Deleting Historic Image Folders :" & ImageFolder
Loop
MsgBox "Historic Images Folders Purged", , "Historic Images Folders Purge Process"
End Function