TKSoft-Online

Problemstellung:

Manchmal ist es erforderlich alte Dateien zu löschen, egal ob es alte Import-, Sicherungsdateien o.ä. sind.

Jetzt möchte man aber die zu löschenden Dateien einschränken, ob nun nach Dateinamen und/oder Dateidatum,

mit Unterverzeichnissen oder ohne.

Für dieses Problem möchte ich hier eine Lösung vorstellen.

Es ist eine Mischung aus FileSystemObject(FSO)- und API-Funktionen.

1. API-Aufrufe zum Löschen der Dateien

Hier kommt die API-Funktion "SHFileOperation" zum Einsatz

1.1. Declare- und Konstantendeklaration

 Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" ( _
ByRef lpFileOp As SHFILEOPSTRUCT) As Long

Private Type SHFILEOPSTRUCT
   hWnd As Long
   wFunc As Long
   pFrom As String
   pTo As String
   fFlags As Integer
   fAnyOperationsAborted As Long
   hNameMappings As Long
   lpszProgressTitle As String
End Type

Private Const FO_DELETE = &H3&
Private Const FOF_ALLOWUNDO = &H40&
Private Const FOF_NOCONFIRMATION = &H10

Wobei die Konstante

Private Const FOF_ALLOWUNDO = &H40&

dafür zuständig ist das die gelöschten Dateien im Papierkorb landen

und die Konstante

FOF_NOCONFIRMATION = &H10

die Bestätigung jeder Dateilöschung deaktiviert.

Dies rufen wir dann in dieser Sub auf:

1.2. Dateien in den Papierkorb löschen

Private Sub Delete_to_Trash(sFilename As String)
   Dim udtFileStructure As SHFILEOPSTRUCT
   With udtFileStructure
     .wFunc = FO_DELETE
     .pFrom = sFilename
     .fFlags = FOF_ALLOWUNDO Or FOF_NOCONFIRMATION
   End With
   SHFileOperation udtFileStructure
End Sub

2. Lesen der Dateien mit FSO, prüfen der Kriterien und löschen der Dateien

Die folgende Sub macht dann die eigentliche Arbeit

Public Sub DeleteCriteriaFiles(sPath As String, Optional sCriteria As String = "*.*", _
                                               Optional dtCriteriaDate As String = "", _
                                               Optional bSubFolder As Boolean = False)

Dim oFSO As New FileSystemObject
Dim oFolder As Folder
Dim oSubFolders As Object, oSubFolder As Folder
Dim oFile As File

Set oFolder = oFSO.GetFolder(sPath)
For Each oFile In oFolder.Files
   If oFile.Name Like sCriteria = True Then
     If dtCriteriaDate <> "" Then
      'Datumskriterium vorhanden
       If CDate(Left(oFile.DateLastModified, 10)) <= CDate(dtCriteriaDate) Then Delete_to_Trash oFile.Path
     Else
     'Datumskriterium nicht vorhanden
     Delete_to_Trash oFile.Path
    End If
   End If
Next oFile

'Unterverzeichnisse einbeziehen
If bSubFolder = True Then
   Set oSubFolders = oFolder.SubFolders
   For Each oSubFolder In oSubFolders
     DeleteCriteriaFiles oSubFolder.Path, sCriteria, dtCriteriaDate, bSubFolder
   Next oSubFolder
End If

Set oFile = Nothing: Set oSubFolders = Nothing
Set oFolder = Nothing: Set oSubFolder = Nothing
Set oFSO = Nothing
End Sub

Folgende Parameter werden der Prozedur übergeben:

sPath As String

Der komplette Pfad des betreffenden Verzeichnisses mit abschliessenden Backslash

Optional sCriteria As String = "*.*"

Das Filterkriterium für die Dateinamen, Standard = Alle (*.*)

Optional dtCriteriaDate As String = ""