Mass Change Passwords!

With all files of a folder the writing protection passwords are changed. In the second example still the sheet protection password becomes, if available, changed. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Module1"

Option Explicit
Public Sub File_Search()
Dim stCalc As XlCalculation
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = "C:\Temp\New" 'adapt
Set objDir = objFSO.GetFolder(strDir)
dirInfo objDir, "*.xls"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String)
Dim objWorkbook As Workbook
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName Then
Set objWorkbook = Workbooks.Open _
(varTMP.Path, Password:="Pass") 'adapt
objWorkbook.SaveAs _
Filename:=varTMP.Path, Password:="New" 'adapt
objWorkbook.Close False
End If
Next
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName
Next
End Sub

The following code belonged In "Module2"

Option Explicit
Public Sub File_Search()
Dim stCalc As XlCalculation
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = "C:\Temp\XLS" 'adapt
Set objDir = objFSO.GetFolder(strDir)
dirInfo objDir, "*.xls"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String)
Dim objWorkbook As Workbook
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And _
varTMP.Name <> ThisWorkbook.Name Then
Set objWorkbook = Workbooks.Open _
(varTMP.Path, Password:="12345", _
WriteResPassword:="12345") 'adapt
If objWorkbook.WriteReserved = False Then
objWorkbook.SaveAs _
Filename:=varTMP.Path, Password:="New" 'adapt
objWorkbook.Close False
Else
objWorkbook.SaveAs _
Filename:=varTMP.Path, Password:="New", _
WriteResPassword:="New" 'adapt
objWorkbook.Close False
End If
End If
Next
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName
Next varTMP
Set objWorkbook = Nothing
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...