| home |  
  

   © 2005 by Friedel Schmidt •  E-Mail  •                      Top  

   | impressum | feedback | home |  


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