Arbeitsmappen-Kennwort ändern

Forumthread: 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.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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.

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

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.

Beliebteste Forumthreads (12 Monate)

Forumthread: Arbeitsmappen-Kennwort ändern

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Arbeitsmappen-Kennwort ändern

Forumthread: Arbeitsmappen-Kennwort ändern

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

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread