Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Passwort für x Dateien in Unterordnern ändern

Passwort für x Dateien in Unterordnern ändern
20.01.2016 16:50:29
Viktoria
Hallo zusammen,
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
Ich hab gedacht, dass sich vielleiht das For... und das Do While... hier nicht zusammenpassen und versucht unter dem Vor dann den Teil mit Passwort-Ändern mit SaveAs abzubilden (gleicher PFad-Dateiname nur anderes Passwort), aber hier sagt mir Excel dann immer, dass es die SaveAs-Methode nicht kennt.
Danke euch (mal wieder) für euren Hirnschmalz.
Grüße
Vicky

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Passwort für x Dateien in Unterordnern ändern
20.01.2016 18:00:53
Sepp
Hallo Vicky,
teste mal.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Passwort_ändern_Subfolder()
Dim objWB As Workbook, objFiles() As Object
Dim strFile As String, strPath As String, lngI As Long, lngRet As Long
Dim CalculationMode As Long, UpdateLinks As Long

Const strOldPW As String = "altesPasswort"

Const strNewPW As String = "neuePasswort"

On Error GoTo ErrorHandler

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  UpdateLinks = .AskToUpdateLinks
  .AskToUpdateLinks = False
  .DisplayAlerts = False
End With

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\"
  .Title = "Passwort ändern - Ordnerauswahl"
  .ButtonName = "Passwort ändern"
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

If Len(strPath) Then
  lngRet = FileSearchFSO(objFiles, strPath, "*.xls*", True)
  If lngRet <> 0 Then
    For lngI = LBound(objFiles) To UBound(objFiles)
      Set objWB = Workbooks.Open(FileName:=objFiles(lngI).Path, UpdateLinks:=False, Password:=strOldPW)
      objWB.SaveAs FileName:=objWB.FullName, Password:=strNewPW
      objWB.Close
      Set objWB = Nothing
    Next
  End If
End If

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'Passwort_ändern_Subfolder'" & 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_ändern_Subfolder", .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 Sub

Private Function FileSearchFSO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
  Optional ByVal SubFolders As Boolean = False) As Long




'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)


Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object
Dim intC As Integer, varFiles As Variant

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.GetFolder(InitialPath)

On Error GoTo ErrExit

If InStr(1, FileName, ";") > 0 Then
  varFiles = Split(FileName, ";")
Else
  Redim varFiles(0)
  varFiles(0) = FileName
End If

For Each mfsoFile In mfsoFolder.Files
  If Not mfsoFile Is Nothing Then
    For intC = 0 To UBound(varFiles)
      If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(varFiles(intC)) Then
        If IsArray(Files) Then
          Redim Preserve Files(UBound(Files) + 1)
        Else
          Redim Files(0)
        End If
        Set Files(UBound(Files)) = mfsoFile
        Exit For
      End If
    Next
  End If
Next

If SubFolders Then
  For Each mfsoSubFolder In mfsoFolder.SubFolders
    FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
  Next
End If

If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
ErrExit:
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function

Gruß Sepp

Anzeige
AW: Passwort für x Dateien in Unterordnern ändern
21.01.2016 14:06:59
Viktoria
Hallo Sepp,
danke, funktioniert wunderbar so!
Welche Stellen müsste ich anpassen, wenn ich auch Word Dateien damit ansprechen möchte bzw. ein Makro für Excel- und eines für Word-Passwort-Änderungen haben möchte?
Also die Dateiendung klar, dann anstatt Workbooks.Open in Documents.Open
Das scheint den Trick aber noch nicht zu tun.
Gruß
Vicky

AW: Passwort für x Dateien in Unterordnern ändern
21.01.2016 14:36:54
Sepp
Hallo Vicky,
stimmt, da muss man etwas mehr anpassen.
Sub Passwort_ändern_Subfolder_Word()
Dim objWord As Object, objDoc As Object, objFiles() As Object
Dim strFile As String, strPath As String, lngI As Long, lngRet As Long
Dim CalculationMode As Long, UpdateLinks As Long

Const strOldPW As String = "altesPasswort"

Const strNewPW As String = "neuePasswort"

On Error GoTo ErrorHandler

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  UpdateLinks = .AskToUpdateLinks
  .AskToUpdateLinks = False
  .DisplayAlerts = False
End With

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\"
  .Title = "Passwort ändern - Ordnerauswahl"
  .ButtonName = "Passwort ändern"
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

If Len(strPath) Then
  lngRet = FileSearchFSO(objFiles, strPath, "*.doc*", True)
  If lngRet <> 0 Then
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = False
    For lngI = LBound(objFiles) To UBound(objFiles)
      Set objDoc = objWord.Documents.Open(FileName:=objFiles(lngI).Path, PasswordDocument:=strOldPW)
      objDoc.Password = strNewPW
      objDoc.SaveAs2 FileName:=objDoc.FullName, Password:=strNewPW
      objDoc.Close
      Set objDoc = Nothing
    Next
    objWord.Quit
  End If
End If

ErrorHandler:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'Passwort_ändern_Subfolder_Word'" & 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_ändern_Subfolder_Word", .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 objWord = Nothing
Set objDoc = Nothing
End Sub

Die Funktion 'FileSearchFSO' bleibt unverändert!
Gruß Sepp

Anzeige
AW: Passwort für x Dateien in Unterordnern ändern
22.01.2016 08:42:50
Viktoria
DANKE! :-)

305 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige