Password protecting multiple files in a directory

Question

I have a directory containing 50 .xlsx files. I need to send these to someone and because of their work environment restrictions I am unable to use Winzip.

I have previously password protected each individual .xlsx file manually but was wondering if there is an automated way I can do this? This is because I am making regular updates to these files (removing the password for ease) and then re-applying a password before sending.

ZygD · Accepted Answer · 2015-10-27T20:11:26.897

The following VBA routines will open all the files (you will not see it) and will save them either with a password or without.

Option Explicit

Const FOLDER As String = "C:\Temp\Test xl file bulk pw protection\"
Const PASSWORD As String = "weakpassword"
Dim app As Excel.Application
Dim strFile As String
Dim wb As Workbook

Sub Password_ON()
    Set app = New Excel.Application
    strFile = Dir(FOLDER)
    app.DisplayAlerts = False
    Do While Len(strFile) > 0
        Set wb = app.Workbooks.Open(FOLDER & strFile)
        wb.SaveAs wb.FullName, , PASSWORD
        wb.Close
        strFile = Dir
    Loop
    app.DisplayAlerts = True
    app.Quit
    Set app = Nothing
End Sub

Sub Password_OFF()
    Set app = New Excel.Application
    strFile = Dir(FOLDER)
    app.DisplayAlerts = False
    Do While Len(strFile) > 0
        Set wb = app.Workbooks.Open(FOLDER & strFile, , , , PASSWORD)
        wb.SaveAs wb.FullName, , vbNullString
        wb.Close
        strFile = Dir
    Loop
    app.DisplayAlerts = True
    app.Quit
    Set app = Nothing
End Sub

Since opening and closing files take time, this is not a very speedy process. The following routines are not actually faster, but they are psychologically faster, as you can see in the statusbar which file is being processed.

Sub Password_ON()
    Set app = New Excel.Application
    strFile = Dir(FOLDER)
    app.DisplayAlerts = False
    Do While Len(strFile) > 0
        Application.StatusBar = "Processing " & strFile
        DoEvents
        Set wb = app.Workbooks.Open(FOLDER & strFile)
        wb.SaveAs wb.FullName, , PASSWORD
        wb.Close
        strFile = Dir
    Loop
    app.DisplayAlerts = True
    app.Quit
    Set app = Nothing
    Application.StatusBar = "READY"
End Sub

Sub Password_OFF()
    Set app = New Excel.Application
    strFile = Dir(FOLDER)
    app.DisplayAlerts = False
    Do While Len(strFile) > 0
        Application.StatusBar = "Processing " & strFile
        DoEvents
        Set wb = app.Workbooks.Open(FOLDER & strFile, , , , PASSWORD)
        wb.SaveAs wb.FullName, , vbNullString
        wb.Close
        strFile = Dir
    Loop
    app.DisplayAlerts = True
    app.Quit
    Set app = Nothing
    Application.StatusBar = "READY"
End Sub

Password protecting multiple files in a directory

1 Answers1