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

Arbeitsmappen-Kennwort ändern

Forumthread: Arbeitsmappen-Kennwort ändern

Arbeitsmappen-Kennwort ändern
16.12.2007 18:51:00
Gerhard
Hallo,
in dem Ordner C:\Test\ befinden sich eine große Anzahl Unterordner. In diesen Unterordnern sind jeweils nur Excel-Dateien gespeichert. Die meisten dieser Dateien sind mit dem Arbeitsmappen-Kennwort "beurteilung" geschützt. Einige Dateien sind mit dem Kennwort "ausbildung" geschützt.
Nun sollen per Makro in allen Unterordnern von allen Excel-Dateien das Arbeitsmappen-Kennwort geändert werden zu "abc".
Wer könnte mir dieses Makro bereitstellen?
Danke und Gruß
Gerhard E.

Anzeige

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Arbeitsmappen-Kennwort ändern
16.12.2007 20:19:12
Josef
Hallo Gerhard,
kopiere diesen Code in ein allgemeines Modul einer leeren Mappe.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub ChangeFilePW()
Dim vOldPW() As Variant, strNewPW As String, strPath As String
Dim a As Variant, result As Long, lngI As Long, i As Integer
Dim objWB As Workbook

On Error GoTo ErrExit
GMS

strPath = "C:\Temp" 'Startverzeichnis - anpassen!
vOldPW = Array("beurteilung", "ausbildung") 'alte Passwörter
strNewPW = "abc" 'neues Passwort

result = FileSearchFSO(a, strPath, "*.xls", True)

If result <> 0 Then
    For lngI = 0 To result - 1
        i = 0
        Do
            On Error Resume Next
            Set objWB = Workbooks.Open(FileName:=a(lngI), Password:=vOldPW(i))
            Err.Clear
            On Error GoTo ErrExit
            i = i + 1
        Loop While objWB Is Nothing And i <= UBound(vOldPW)
        
        If Not objWB Is Nothing Then
            objWB.SaveAs a(lngI), Password:=strNewPW
            objWB.Close True
        End If
        
    Next
End If

ErrExit:
Set objWB = Nothing
GMS True
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

'by J.Ehrensberger
Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long


Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.GetFolder(InitialPath)

On Error Resume Next

For Each mfsoFile In mfsoFolder.Files
    If Not mfsoFile Is Nothing Then
        If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
            If IsArray(Files) Then
                Redim Preserve Files(UBound(Files) + 1)
            Else
                Redim Files(0)
            End If
            Files(UBound(Files)) = mfsoFile
        End If
    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
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function

Gruß Sepp

Anzeige
AW: Arbeitsmappen-Kennwort ändern
16.12.2007 22:06:33
Gerhard
Hallo Sepp,
das läuft super! Danke für Deine große Hilfe!
Gruß
Gerhard E.

AW: @ Sepp: Arbeitsmappen-Kennwort ändern
17.12.2007 19:07:42
Gerhard
Hallo Sepp,
heute habe ich das Makro nochmals in einem Ordner mit ca. 220 Unterordnern eingesetzt. Dabei wurden nur wenige Unterordner (6-8) und die darin enthaltenen Dateien richtig bearbeitet und das jeweilige Arbeitsmappen-Kennwort geändert.
Es gab keine Fehlermeldung o.ä. nur in allen restlichen Ordnern/Datein wurden die Passwörter nicht geändert.
Woran kann das liegen? Ich bin ratlos.
Gruß
Gerhard E.

Anzeige
AW: @ Sepp: Arbeitsmappen-Kennwort ändern
17.12.2007 20:40:20
Josef
Hallo Gerhard,
schwer zu sagen woran das liegt. Probier mal den modifizierten Code, da wird am Ende eine Textdatei mit den Fehlermeldungen ausgegeben.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long

Sub ChangeFilePW()
Dim vOldPW() As Variant, strNewPW As String, strPath As String
Dim a As Variant, result As Long, lngI As Long, i As Integer
Dim objWB As Workbook
Dim strError As String, strTmpFile As String, r As Long

On Error GoTo ErrExit
GMS

strTmpFile = Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Error.txt"

strPath = "C:\Temp" 'Startverzeichnis - anpassen!
vOldPW = Array("beurteilung", "ausbildung") 'alte Passwörter
strNewPW = "abc" 'neues Passwort

result = FileSearchFSO(a, strPath, "*.xls", True)

If result <> 0 Then
    For lngI = 0 To result - 1
        i = 0
        Do
            On Error Resume Next
            Set objWB = Workbooks.Open(FileName:=a(lngI), Password:=vOldPW(i))
            If Err.Number > 0 Then
                strError = strError & "File: " & a(lngI) & _
                    ", PassWord: '" & vOldPW(i) & "'" & _
                    ", Error: " & Err.Description & vbLf
                Err.Clear
            End If
            On Error GoTo ErrExit
            i = i + 1
        Loop While objWB Is Nothing And i <= UBound(vOldPW)
        
        If Not objWB Is Nothing Then
            objWB.SaveAs a(lngI), Password:=strNewPW
            objWB.Close True
        End If
        
    Next
End If

If Len(strError) > 0 Then
    Open strTmpFile For Output As #1
    Print #1, strError
    Close #1
    ShellExecute 0, "Open", strTmpFile, "", "", 0
End If

ErrExit:
Set objWB = Nothing
GMS True
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

'by J.Ehrensberger
Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long


Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.GetFolder(InitialPath)

On Error Resume Next

For Each mfsoFile In mfsoFolder.Files
    If Not mfsoFile Is Nothing Then
        If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
            If IsArray(Files) Then
                Redim Preserve Files(UBound(Files) + 1)
            Else
                Redim Files(0)
            End If
            Files(UBound(Files)) = mfsoFile
        End If
    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
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function

Gruß Sepp

Anzeige
AW: @ Sepp: Arbeitsmappen-Kennwort ändern
17.12.2007 22:13:00
Gerhard
Hallo Sepp,
auch jetzt kein anderes Ergebnis, und wo wird die Textdatei erzeugt/ausgegeben?
Gruß
Gerhard E.
;

Forumthreads zu verwandten Themen

Anzeige
Anzeige
Anzeige
Entdecke relevante Threads

Schau dir verwandte Threads basierend auf dem aktuellen Thema an

Alle relevanten Threads mit Inhaltsvorschau entdecken

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige