Smazání souborů určitého stáří

Funkce:
Public Function DeleteOldFiles(DaysOld As Long, FileSpec As _
   String,Optional ComparisonDate As Variant) As Boolean

   'Smaže všechny soubory, které jsou o DaysOld starší než
   'ComparisonDate, které je defaultně nastaveno na Now
   'NÁVRATOVÉ HODNOTY: True, pokud je funkce úspěšná, jinak False 
   'Nesmaže soubory ReadOnly, Hidden nebo System

   Dim sFileSpec As String
   Dim dCompDate As Date
   Dim sFileName As String
   Dim sFileSplit() As String
   Dim iCtr As Integer, iCount As Integer
   Dim sDir As String

   sFileSpec = FileSpec

   If IsMissing(ComparisonDate) Then
      dCompDate = Now
   ElseIf Not IsDate(ComparisonDate) Then
         DeleteOldFiles = False
         Exit Function
      Else
         dCompDate = CDate(Format(ComparisonDate, "mm/dd/yyyy"))
   End If

   sFileName = Dir(sFileSpec)

   If sFileName = "" Then
      DeleteOldFiles = False
      Exit Function
   End If

   Do
      If sFileName = "" Then Exit Do
      If InStr(sFileSpec, "\") > 0 Then
         sFileSplit = Split(sFileSpec, "\")
         iCount = UBound(sFileSplit) - 1
         For iCtr = 0 To iCount
            sDir = sDir & sFileSplit(iCtr) & "\"
         Next
         sFileName = sDir & sFileName
      End If
      On Error GoTo errhandler:
      If DateDiff("d", FileDateTime(sFileName), dCompDate) >= DaysOld Then
         Kill sFileName
      End If
      sFileName = Dir
      sDir = ""
   Loop

   DeleteOldFiles = True

   Exit Function

errhandler:
   DeleteOldFiles = False
   Exit Function

End Function

Zpět