Option Explicit
On Error Resume Next
Dim FS, Liste, Nr, Verzeichnis, Objekt
Dim Anzahl, WshShell
Set WshShell = CreateObject("WScript.Shell")
Set Liste = WScript.Arguments
Set FS = CreateObject("Scripting.FileSystemObject")
Anzahl = 0
If Liste.Count > 0 Then
' Then wird ausgeführt, wenn aus dem Explorer Dateien
' mit Drag & Drop auf diese Skript-Datei gezogen wurden
For Nr = 0 To Liste.Count - 1
DateiSystemDurchsuchen Liste(Nr)
Next
Else
' Else wird ausgeführt, wenn dieses Skript gestartet
' wurde, ohne dass Argumente übergeben wurden
' Ruft einen Dialog von Windows auf, mit dem eine
' Datei oder ein Ordner ausgewählt werden kann
Set Verzeichnis = CreateObject("Shell.Application") _
.BrowseForFolder(0, "Datei oder Verzeichnis wählen" _
, &H4011, 17)
' Skript beenden, falls im Dialog die Schaltfläche
' Abbrechen gedrückt wurde
If TypeName(Verzeichnis) = "Nothing" Then WScript.Quit
Objekt = LCase(TypeName(Verzeichnis.ParentFolder))
If (InStr(1, Objekt, "folder*")>0) Then
For Each Objekt In Verzeichnis.ParentFolder.Items
If Objekt.Name = Verzeichnis.Title Then Exit For
Next
End If
DateiSystemDurchsuchen Objekt.Path
End If
' *** Ende des Scripts
' ---------------------------------------------------------- '
' Rekursives Unterprogramm um das Dateisystem zu durchsuchen
' ---------------------------------------------------------- '
Private Sub DateiSystemDurchsuchen(Pfad)
Dim Ordner, UnterOrdner, Datei
If FS.FolderExists(Pfad) Then
' Then: Falls Ordner übergeben wurde
Set Ordner = FS.GetFolder(Pfad)
' Papierkorb nicht bearbeiten
If LCase(Ordner.Name) = "recycled" Then Exit Sub
' Funktion Bearbeiten() für Ordner aufrufen
If Not Bearbeiten(Ordner, False) Then Exit Sub
' Alle Dateien im Ordner bearbeiten
For Each Datei In Ordner.Files
' Prozedur Bearbeiten() für Dateien aufrufen
If Not Bearbeiten(Datei, True) Then Exit For
Next
' Alle Unterordner rekursiv bearbeiten
For Each UnterOrdner In Ordner.SubFolders
' Einstieg In die Rekursion
DateiSystemDurchsuchen UnterOrdner
Next
ElseIf FS.FileExists(Pfad) Then
' Else: Falls eine einzelne Datei übergeben wurde
Bearbeiten FS.GetFile(Pfad), True
End If
End Sub
' Zeigt 5 Sekunden lang die Anzahl der bearbeiteten Dateien
WshShell.PopUp Anzahl & " Links gelöscht", 5, "Tote Links"
'*** Ende des Skripts
' Diese Prozedur prüft, ob ein Link existiert
Private Function Bearbeiten(Objekt, IstDatei)
Bearbeiten = True ' In jedem Falle weitermachen
Dim Quelle, LaufWerk, Typ
' Funktion verlassen, wenn ein Ordner übergeben wurde
If Not IstDatei Then Exit Function
' Funktion verlassen, wenn die Datei kein Link ist
If LCase(FS.GetExtensionName(Objekt)) <> "lnk" _
Then Exit Function
' Auf welche Datei/Verzeichnis zeigt der Link ?
Quelle = WshShell.CreateShortcut(Objekt).TargetPath
' Funktion verlassen, wenn die Datei / Ordner, auf
' die der Link zeigt, existiert
If FS.FileExists(Quelle) Then Exit Function
If FS.FolderExists(Quelle) Then Exit Function
' Laufwerksbuchstaben bestimmen
LaufWerk = FS.GetDriveName(Quelle)
' Existiert wenigstens das Laufwerk ?
If FS.DriveExists(LaufWerk) Then
' Laufwerkstyp bestimmen
Typ = FS.Drives(CStr(LaufWerk)).DriveType
' Falls der Link auf eine Datei/Ordner auf einer
' lokalen Festplatte (2) oder ein Netzlaufwerk (3)
' verweist, dann löschen
If (Typ = 2) Or (Typ = 3) Then
FS.DeleteFile Objekt
Anzahl = Anzahl + 1
End If
End If
End Function
|