Inhaltsverzeichnis
Suchen
Links
|
|
Alle Excel-Dateien eines Ordners mit Passwort schützen
Versionen: Excel 97, 2000 und XP, 2002, 2003
Sofern man seine Excel-Arbeitsmappen alle mit einem Passwort versehen hat, kann es mühsam werden dieses Passwort bei Bedarf in allen Mappen zu ändern.
Eine recht komfotable Möglichkeit alle Passwörter "in einem Rutsch" zu ändern kann man mit den nachfolgenden Beispielen erreichen:
Voraussetzung ist, dass alle Dateien dasselbe Kennwort oder überhaupt kein Kennwort besitzen.
Nachfolgenden Code in ein Modul einfügen:
'Diese Zeile für beide Versionen ganz am Anfang des Codefensters eingeben:
Const strVerzeichnis As String = "C:\Test\"
'Version für Excel 97 und Excel 2000:
Sub Ordnerschutz97_2000()
Dim PwdAlt, PwdNeu
Dim strDatei As String
Dim objMappe As Workbook
Dim strU_Verzeichnis As String
Dim fso As Object
Dim i As Long
On Error GoTo ErrorHandler
PwdAlt = Application.InputBox("Geben Sie das bisher benutzte Kennwort ein:")
If PwdAlt = False Then Exit Sub
PwdNeu = Application.InputBox("Geben Sie ein neues Kennwort ein:")
If PwdNeu = False Then Exit Sub
Application.ScreenUpdating = False
strDatei = Dir(strVerzeichnis & "*.xls")
If strDatei <> "" Then
strU_Verzeichnis = strVerzeichnis & "TempDir"
MkDir strU_Verzeichnis
End If
Do While strDatei <> ""
Set objMappe = Application.Workbooks.Open _
(Filename:=strVerzeichnis & strDatei, Password:=PwdAlt)
With objMappe
.SaveAs Filename:=strU_Verzeichnis & "\" & _
strDatei, Password:=PwdNeu
.Close SaveChanges:=False
End With
Set objMappe = Nothing
strDatei = Dir
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
With fso
.DeleteFile strVerzeichnis & "*.xls"
.MoveFile strU_Verzeichnis & "\*.xls", strVerzeichnis
End With
RmDir strU_Verzeichnis
Set fso = Nothing
Ende:
MsgBox "Alle Dateien im Ordner" & vbCr & _
strVerzeichnis & vbCr & "bearbeitet ..."
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Fehler " & Err.Number & " bei Datei " & _
strDatei & ":" & vbCr & _
Err.Description
Resume Ende
End Sub
'Version für Excel 2002/XP/2003:
Sub Ordnerschutz2002()
Dim PwdAlt, PwdNeu
Dim strDatei As String, strFehler As String
Dim objMappe As Workbook
On Error GoTo ErrorHandler
PwdAlt = Application.InputBox("Geben Sie das bisher benutzte Kennwort ein:")
If PwdAlt = False Then Exit Sub
PwdNeu = Application.InputBox("Geben Sie ein neues Kennwort ein:")
If PwdNeu = False Then Exit Sub
Application.ScreenUpdating = False
strDatei = Dir(strVerzeichnis & "*.xls")
Do While strDatei <> ""
Set objMappe = Application.Workbooks.Open _
(Filename:=strVerzeichnis & strDatei, _
Password:=PwdAlt)
With objMappe
.Password = PwdNeu
.Close SaveChanges:=True
End With
Set objMappe = Nothing
Weiter:
strDatei = Dir
Loop
'Ende:
If strFehler = "" Then
MsgBox "Alle Dateien im Ordner" & vbCr & _
strVerzeichnis & vbCr & "bearbeitet ..."
Application.ScreenUpdating = True
Exit Sub
Else
MsgBox strFehler, vbOKOnly, "Es sind Fehler bei folgenden Arbeitsmappen aufgetreten:"
End If
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
If strFehler = "" Then
strFehler = strDatei
Cells(1, 1).Value = "Es traten Fehler bei folgenden Mappen auf:"
Cells(2, 1).Value = "Name der Mappe"
Cells(2, 2).Value = "Fehlernummer"
Cells(2, 3).Value = "Fehlerbeschreibung"
Range("A2:C2").Columns.AutoFit
i = 3
Cells(i, 1).Value = strDatei
Cells(i, 2).Value = Err.Number
Cells(i, 3).Value = Err.Description
Else
strFehler = strFehler & ", " & strDatei
i = i + 1
Cells(i, 1).Value = strDatei
Cells(i, 2).Value = Err.Number
Cells(i, 3).Value = Err.Description
End If
Resume Weiter
' Resume Ende
End Sub
Die Unterschiede ergeben sich dadurch, dass es erst seit Excel 2002 eine "Password"-Eigenschaft des "Workbook"-Objekts gibt. In den früheren Versionen müssen die Dateien zunächst mit Kennwortschutz in einem temporären Ordner gespeichert werden, um sie anschließend mit Hilfe des "FileSystemObject" wieder an den ursprünglichen Ort zu verschieben.
Die unterschiedliche Fehlerbehandlung in den beiden Beispielen hat nichts mit den Unterschieden zwischen Excel 97/2000 und den nachfolgenden Versionen zu tun.
Sie sollen leiglich verschiedene Alternativen aufzeigen.
In beiden Varianten wird der Ordner, in dem sich die Excel-Dateien befinden, in einer Konstanten festgelegt. Deshalb muss die Zeile
Const strVerzeichnis As String = "C:\Test\"
an die eigenen Gegebenheiten angepasst werden!
Nach Aufruf der Prozedur wird als erstes nach dem alten Kennwort gefragt. Falls die Dateien noch nicht kennwortgeschützt sind, das Eingabefeld leer lassen und einfach auf Ok klicken. Danach erscheint ein zweites Dialogfeld, in dem das neue Kennwort eingegeben werden kann. Dieses Kennwort gilt dann für alle Excel-Dateien des Ordners.
Da ja nun alle Dateien über dasselbe Kennwort verfügen, kann man das gleichzeitige Öffnen mehrerer Dateien mit einem Makro, das für alle Excel-Versionen identisch ist, vereinfachen. Die folgende Prozedur zeigt das übliche Dialogfeld zum Öffnen von Dateien an, sodass eine oder mehrere Arbeitsmappen ausgewählt werden können. Anschließend erfolgt die (einmalige) Abfrage des Kennworts. Wenn die Angabe korrekt ist, öffnet die Prozedur alle ausgewählten Dateien in einem Schritt.
Sub MitPasswortOeffnen()
Dim Pwd
Dim arrDateien
Dim i As Long
On Error GoTo Fehler
arrDateien = Application.GetOpenFilename _
(FileFilter:="Excel-Dateien (*.xls),*.xls", _
MultiSelect:=True)
If IsArray(arrDateien) Then
Pwd = Application.InputBox _
("Geben Sie das Kennwort zum Öffnen der " & _
"Dateien ein:")
If Pwd = False Then Exit Sub
For i = 1 To UBound(arrDateien)
Application.Workbooks.Open _
Filename:=arrDateien(i), _
Password:=Pwd
Weiter:
Next i
End If
Ende:
Exit Sub
Fehler:
MsgBox arrDateien(i) & vbLf & vbLf & _
"Fehlernummer " & Err.Number & ":" & _
vbCr & Err.Description
' Resume Ende
Resume Weiter
End Sub
Im Beispiel wird bei einem falschen Passwort eine Fehlermeldung mit dem Namen der Datei und der Fehlerbeschreibung angezeigt.
Anschließend werden die weiteren Dateien abgearbeitet und geöffnet.
Soll die Ausführung sofort nach einem Fehler gestoppt werden, dann die zwei letzten Zeilen so anpassen:
Resume Ende
' Resume Weiter
|