Arbeitsmappen-Kennwort ändern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread