'v3.6*****************************************************  

' File:   deltree.vbs  

' Autor:  dieseyer@gmx.de   

'         dieseyer.de  

'  

' Löscht alle Dateien und danach alle Verzeichnisse in 

' einem Verzeichnis - vorher werden die Attribute gelöscht. 

' Zieht man ein Verzeichnis auf das Skript, werden alle 

' enthaltene Dateien und Unterverzeichnisse gelöscht. 

' Zieht man eine Datei auf das Skript, wird das Verzeich- 

' nis, in dem sich die Datei befindet, ermittelt und wie 

' beschrieben gelöscht. 

'*********************************************************  

  

Option Explicit  

  

Dim WSHShell, fso, oArgs  

Dim i, Text, Pfad 

  

Set WSHShell = WScript.CreateObject("WScript.Shell")  

Set fso      = WScript.CreateObject("Scripting.FileSystemObject")  

set oArgs    = Wscript.Arguments   

  

If oArgs.Count > 0 Then                      ' gibt es Argumente?   

  Pfad = oArgs.item(0)                       ' erstes Argument   

  

Else                                         ' es gibt keine Argumente!  

 

  Text = ""  

  Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF   

  Text = Text & "Ein Verzeichnis auf das Skript ziehen & fallen lassen" & vbCRLF   

  Text = Text & ". . . und es wird gelöscht." & vbCRLF & vbCRLF   

  Text = Text & "Eine Datei auf das Skript ziehen & fallen lassen" & vbCRLF   

  Text = Text & ". . . und das Verzeichnis, in dem sich die Datei befindet wird gelöscht." & vbCRLF & vbCRLF  

  Text = Text & "ACHTUNG: Der Papierkorb bleibt leer!!!" 

 

  WSHShell.Popup Text , 30, WScript.ScriptName, 64 + 0 

  WScript.Quit  

 

End If   

   

if not fso.FolderExists( Pfad ) then  

  WSHShell.Popup UCase(Pfad) & "   entält kein Verzeichnis!" & vbCRLF & vbCRLF & " . . . das ist das Ende.", 30, WScript.ScriptName, 64 + 0 

  WScript.Quit  

End If  

  

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 

   SicherheitsAbfrage  Pfad       ' Sub Aufruf 

if DelTree( Pfad ) = true then    ' Function Aufruf 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 

  WSHShell.Popup UCase(Pfad) & " true  ist jetzt leer!",        13, WScript.ScriptName, 64 + 0  

Else 

  WSHShell.Popup UCase(Pfad) & " konnte nicht geleert werden!", 30, WScript.ScriptName, 48 + 0  

End If 

 

WScript.Quit 

 

'*********************************************************  

  Function DelTree ( Pfad )  

'*********************************************************  

  Dim fso, oFolders, oSubFolder, oFiles, WSHShell  

  Dim Text, DateiX, VerzX, Txt 

 

  Set WSHShell = WScript.CreateObject("WScript.Shell")  

  Set fso      = WScript.CreateObject("Scripting.FileSystemObject")  

 

  DelTree      = true 

  if fso.FileExists( Pfad ) then Pfad = fso.GetParentFolderName( Pfad )   

     ' obige Zeile wird nur ausgeführt, wenn "Pfad" eine Datei ist  

 

' Datei-Attribute System, Readonly, Hidden zurück setzen 

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  

  Text = "%comspec% /c Attrib """ & Pfad & "\*.*"" /S -s -r -h " 

  WSHShell.run Text, 4, True 

 

  

' Dateiliste  

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  

  Text = ""  

  Set oFolders = fso.GetFolder( Pfad )    

  Set oFiles   = oFolders.Files  

    For Each DateiX In oFiles  

      Text =  Text & DateiX.Path & vbCRLF  

 

On Error Resume Next 

        fso.DeleteFile DateiX.Path, True    ' True: Löschen erzwingen 

        if not err.number = 0 then DelTree = False 

On Error GoTo 0 

 

    Next  

  Set oFiles   = nothing  

  Set oFolders = nothing  

  

  If Text = "" then Text = "keine Dateien vorhanden."  

  

  WSHShell.Popup "In   " & UCase(Pfad) & "   wurden folgende Dateien gelöscht:" & vbCRLF & vbCRLF & Text, 3, WScript.ScriptName, 64 + 0 

  

  

' Verzeichnisliste  

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  

  Text = ""  

  Set oFolders = fso.GetFolder( Pfad )    

  Set oSubFolder = oFolders.SubFolders  

    For Each VerzX In oSubFolder  

      Text = Text    & VerzX.Path  & vbCRLF  

 

On Error Resume Next 

        fso.DeleteFolder VerzX.Path, True    ' True: Löschen erzwingen 

        if not err.number = 0 then DelTree = False 

On Error GoTo 0 

 

    Next  

 

  Set oFiles   = nothing  

  Set oFolders = nothing  

  

  If Text = "" then Text = "keine Unterverzeichnisse vorhanden."  

  

  WSHShell.Popup "In   " & UCase(Pfad) & "   wurden folgende Verzeichnisse gelöscht:" & vbCRLF & vbCRLF & Text, 3, WScript.ScriptName, 64 + 0 

 

  Set WSHShell = nothing 

  Set fso      = nothing 

 

End Function ' DelTree  

'*********************************************************  

  

 

'*********************************************************  

Sub SicherheitsAbfrage( Pfad ) ' Anfang 

'*********************************************************  

 

  Text = ""  

  Text = Text & "Es wird jetzt das Verzeichnis" & vbCRLF & vbCRLF  

  Text = Text & vbTAB & UCase( Pfad )  

  Text = Text & vbCRLF & vbCRLF & "unwiederbringlich gelöscht." & vbCRLF & vbCRLF  

  Text = Text & "ACHTUNG: Der Papierkorb bleibt leer!!!" 

 

If not vbYes = WSHShell.Popup ( Text , 30, WScript.ScriptName, 48 + 4 + 256 ) then   

  WSHShell.Popup UCase(Pfad) & vbTab & vbCRLF & vbCRLF & vbTab & "wird nicht gelöscht!" & vbCRLF & vbCRLF & vbTab & " . . . das ist das Ende.", 30, WScript.ScriptName, 64 + 0 

  WScript.Quit     

End if 

 

 

  Text = vbCRLF  

  Text = Text & "DIE LETZTE WANUNG!" & vbCRLF & vbCRLF  

  Text = Text & "Es wird jetzt das Verzeichnis" & vbCRLF & vbCRLF  

  Text = Text & vbTAB & UCase( Pfad )  

  Text = Text & vbCRLF & vbCRLF & "unwiederbringlich gelöscht - dies betrifft auch Dateien mit " & vbCRLF  

  Text = Text & "SYSTEM, READONLY- oder HIDDEN-Attributen!" & vbCRLF & vbCRLF  

  Text = Text & "ACHTUNG: Der Papierkorb bleibt leer!!!" 

 

If not vbOK = WSHShell.Popup ( Text , 30, WScript.ScriptName, 16 + 1 + 256 ) then   

  WSHShell.Popup UCase(Pfad) & vbTab & vbCRLF & vbCRLF & vbTab & "wird nicht gelöscht!" & vbCRLF & vbCRLF & vbTab & " . . . das ist das Ende.", 30, WScript.ScriptName, 64 + 0 

  WScript.Quit     

End if 

  Text = ""  

 

  Set fso = nothing 

 

End Sub ' SicherheitsAbfrage 

'*********************************************************