Dateien erst nach Abgleich mit Archiv löschen

Set fso = CreateObject("Scripting.FileSystemObject")  
Set WSHShell = WScript.CreateObject("WScript.Shell")  
On Error Resume Next

'* hier eigenen Bedürfnissen anpassen *  

strOrdnerliste = "D:\Sicherung\Ordnerliste.txt"  
strAusschlussliste = "D:\Sicherung\Ausschluss.txt"  

Set objOrdnerliste = fso.OpenTextFile(strOrdnerliste, 1)
Verzeichnis = Split(objOrdnerliste.ReadAll, vbCrLF)
objOrdnerliste.Close

Set objAusschlussliste = fso.OpenTextFile(strAusschlussliste, 1)
If Not objAusschlussliste.AtEndOfStream Then 'falls nicht schon am Dateiende (= Datei ist leer) ...  
	Exclude = objAusschlussliste.ReadLine ' ... erste Zeile lesen und speichern ...  
Else
	Exclude = "" '... ansonsten gibt es keine Ausnahmen beim Löschen.  
End If

objAusschlussliste.Close

Aufheben = 1 'Anzahl der Tage  

' * Ende der Anpassungen *  

Heute = Date()
For n = 0 To UBound(Verzeichnis) 
	Set Ordner = fso.GetFolder(Verzeichnis(n))
	DeleteInFolder(Ordner)
Next

Sub DeleteInFolder(Ordner)
Set Dateien = Ordner.Files
' Alle Dateien in diesem Ordner abklappern  
For Each Datei In Dateien
	If Datei.DateLastModified < (Heute - Aufheben) Then
		Ext = Mid(Datei.Name, InStrRev(Datei.Name, "."))  
		If InStr(Exclude, Ext) = 0 Then
			On Error Resume Next
			Datei.Delete
			If Err And Err <> 70 Then MsgBox "Unerwarteter Fehler (Code=" & Err & ")", vbCritical: WScript.Quit  
			On Error Goto 0
		End If
	End If
Next

'Unterordner abklappern, DeleteInFolder rekursiv aufrufen  
For Each Unter In Ordner.SubFolders
	DeleteInFolder(Unter)
	If (Unter.SubFolders.Count + Unter.Files.Count) = 0 Then Unter.Delete
Next
End Sub