Passwort für x Dateien in Unterordnern ändern
20.01.2016 16:50:29
Viktoria
ich hab mal wieder ein VBA-Problem und komme nicht weiter.
Ziel soll sein, dass in einem Ordner mit verschiedenen Unterordnern in allen Excel-Dateien, die dort abliegen ein bestehendes Passwort zum Öffnen in ein neues geändert wird. Ich dachte ich könnte hierfür einfach diese beiden Makros kombinieren:
- Passwort ändern: https://www.herber.de/forum/archiv/1468to1472/t1468267.htm
- Unterordner einbeziehen: https://www.herber.de/forum/archiv/1468to1472/t1468266.htm
Und dabei hänge ich jetzt irgendwie. Das Makro läuft, findet & öffnet die Dateien und tut dann... nichts mehr. Jeweils einzeln funktionieren die beiden Makros, aber an der Stelle reichen meine spärlichen VBA-Kenntnisse leider nicht aus, um zu identifizieren, wo der Fehler liegt.
Könnt ihr mir hier helfen?
Der Code ist aktuell:
Sub Passwort_aendern2()
Dim DateiName As String
Dim quelle As String
Dim i As Long
Dim strDatei As String
Dim lngZeile As String
Dim strMesh As String
Dim suche As Variant
Dim objWB As Workbook
Dim CalculationMode As Long, UpdateLinks As Long
Application.ScreenUpdating = False
strMesh = ThisWorkbook.Name
ReDim dateien(0)
dateien(0) = 0
quelle = "H:\pw\" 'Pfad eintragen mit Backslash
If Right(quelle, 1) = "\" Then quelle = Left(quelle, Len(quelle) - 1)
If Dir(quelle & "\") = "" Then
MsgBox "Der Pfad wurde nicht gefunden!"
End
End If
Call txtsuchen(quelle)
If dateien(0) = 0 Then
MsgBox "Keine Dateien gefunden!"
Else
'Daten auslesen
For i = 1 To dateien(0)
DateiName = dateien(i)
strDatei = Right(DateiName, InStr(1, StrReverse(DateiName), "\") - 1)
'die Mappen aufmachen
Workbooks.Open DateiName, Password:="pw_alt"
'hier jetzt den Code einfügen, was mit der Datei gemacht werden soll
'PW ändern
With Workbooks(strMesh)
Const strOldPW As String = "pw_alt"
Const strNewPW As String = "pw_neu"
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
UpdateLinks = .AskToUpdateLinks
.AskToUpdateLinks = False
.DisplayAlerts = False
End With
strDatei = Dir(quelle & "*.xls*", vbNormal)
Do While strDatei ""
Set objWB = Workbooks.Open(Filename:=quelle & strDatei, UpdateLinks:=False, Password:= _
strOldPW)
objWB.SaveAs Filename:=objWB.FullName, Password:=strNewPW
objWB.Close
Set objWB = Nothing
strDatei = Dir
Loop
ErrorHandler:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'Passwort_aendern2'" & vbLf & String(25, "-") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, 81968, "VBA - Fehler in Prozedur - Passwort_aendern2", .HelpFile, . _
HelpContext
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.AskToUpdateLinks = UpdateLinks
.CutCopyMode = False
.StatusBar = False
End With
Set objWB = Nothing
End With
Next i
End If
Application.ScreenUpdating = True
End Sub
Function txtsuchen(quelle As String)
Dim suche
Dim ordner()
Dim i As Long
ReDim ordner(0)
ordner(0) = 0
ChDrive (Left(quelle & "\", 3))
ChDir (quelle)
'Ordner durchschauen
suche = Dir(quelle & "\*.*", vbDirectory)
Do Until suche = ""
'Normale Dateien rausfiltern
If (GetAttr(quelle & "\" & suche) = 16) Then
'die hier ankommen, sind Ordner, extra speichern
ordner(0) = ordner(0) + 1
ReDim Preserve ordner(ordner(0))
ordner(ordner(0)) = suche
Else
If Right(suche, 5) = ".xlsx" Then
dateien(0) = dateien(0) + 1
ReDim Preserve dateien(dateien(0))
dateien(dateien(0)) = quelle & "\" & suche
End If
End If
suche = Dir()
Loop
'jetzt durch die Ordner gehen
For i = 1 To UBound(ordner)
If Dir(ordner(i), vbNormal) = "" And Left(ordner(i), 1) "." Then
Call txtsuchen(quelle & "\" & ordner(i))
ChDir (quelle)
End If
Next
End Function
Danke euch (mal wieder) für euren Hirnschmalz.
Grüße
Vicky