AW: Datei Schreibschutz prüfen
25.11.2005 08:04:13
Heiko
Moin Eres,
teste mal dieses Script in einer leeren Tabelle.
Den Pfad und das WriteResPassword:="test" mußt du dir noch anpassen. Das Password:="test" braucht nicht verändert zu werden.
Das hat bei mir mit ein paar Testdateien zumindest rausgekriegt ob das Schreibschutzpasswort richtig ist oder nicht.
Aber in Ruhe prüfen und zur Kontrolle auch mal ein File aus der Liste öffnen, denn so richtig kommt man da mit einfachen Mitteln eigentlich nicht ran (siehe auch post von Nepumuk).
Sub Schreibschutz()
Dim lngI As Long, lngN As Long
On Error Resume Next
ActiveSheet.Cells.Delete
Application.EnableEvents = False
Application.ScreenUpdating = False
lngN = 1
With Application.FileSearch
.LookIn = "H:\EXCEL\Muell\Schreibschutz"
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
.Execute
For lngI = 1 To .FoundFiles.Count
Application.StatusBar = "Datei " & lngI & " von " & .FoundFiles.Count & " ! File => " & .FoundFiles(lngI)
Workbooks.Open .FoundFiles(lngI), WriteResPassword:="test", Password:="test"
If ActiveWorkbook.WriteReserved = False Then
Workbooks("Mappe1").ActiveSheet.Cells(lngN, 1) = "Kein oder falsches Schreibschutzpasswort !"
Workbooks("Mappe1").ActiveSheet.Cells(lngN, 2) = .FoundFiles(lngI)
lngN = lngN + 1
Else
Workbooks("Mappe1").ActiveSheet.Cells(lngN, 1) = "Richtiges Passwort vorhanden !"
Workbooks("Mappe1").ActiveSheet.Cells(lngN, 2) = .FoundFiles(lngI)
lngN = lngN + 1
End If
Workbooks(Right(.FoundFiles(lngI), Len(.FoundFiles(lngI)) - InStrRev(.FoundFiles(lngI), "\"))).Close False
Next lngI
End With
ActiveSheet.Range("A:B").Columns.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.StatusBar = False
End Sub
Gruß Heiko
PS: Rückmeldung wäre nett !