While trying to help someone out in a forum, I developed the following procedure that can be called to secure an Excel workbook with a password, which will be required by users when trying to open the file, and thought it might be of use to other.
'---------------------------------------------------------------------------------------
' Procedure : XLS_SecureWrkBk
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Secure an Excel Wordbook with a Password to open the file
' Returns True is Successful
' Returns False when the process was unsuccessful
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFilePath : Path to the Excel Workbook
' sFileName : File name of the Workbook without the extension
' sFileExt : Extension of the Workbook file (typically xls or xlsx)
' sPwd : Password to set
'
' Usage:
' ~~~~~~
' Call XLS_SecureWrkBk("C:\Temp\", "Test", "xls", "MyPassword")
' Call XLS_SecureWrkBk("C:\Temp", "Test", "xlsx", "MyPassword")
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2019-01-14 Initial Release
'---------------------------------------------------------------------------------------
Public Function XLS_SecureWrkBk(ByVal sFilePath As String, ByVal sFileName As String, _
ByVal sFileExt As String, ByVal sPwd As String) As Boolean
Dim oExcel As Object
Dim oExcelWrkBk As Object
On Error GoTo Error_Handler
'Ensure properly formatted path was supplied, adjust as req'd
If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
'Validate that the supplied file actually exists
If Len(Dir(sFilePath & sFileName & "." & sFileExt)) = 0 Then
MsgBox "The file '" & sFilePath & sFileName & "." & sFileExt & _
"' cannot be located.", vbCritical Or vbOKOnly, _
"Unable to Secure the Excel Workbook"
GoTo Error_Handler_Exit
End If
'Rename the file, so we can save the secured version with the proper name
Name sFilePath & sFileName & "." & sFileExt As sFilePath & "MyTmp" & "." & sFileExt
Set oExcel = CreateObject("Excel.Application") 'Start Excel
oExcel.Visible = False 'Keep Excel hidden
oExcel.ScreenUpdating = False 'Don't update visuals during this process
oExcel.DisplayAlerts = False 'Don't display any warning prompts
'Load the unsecured Workbook
Set oExcelWrkBk = oExcel.WorkBooks.Open(sFilePath & "MyTmp" & "." & sFileExt) 'Start a new workbook
'Save a new Secured version with the proper name
oExcelWrkBk.SaveAs sFilePath & sFileName & "." & sFileExt, , sPwd
oExcelWrkBk.Close False 'Close the workbook
oExcel.Quit 'Close Excel
'Delete the renamed and unsecured workbook
Kill sFilePath & "MyTmp" & "." & sFileExt
XLS_SecureWrkBk = True
Error_Handler_Exit:
On Error Resume Next
Set oExcelWrkBk = Nothing
Set oExcel = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: XLS_SecureWrkBk" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
oExcel.DisplayAlerts = True
oExcel.ScreenUpdating = True
oExcel.Visible = True 'Make excel visible to the user
Resume Error_Handler_Exit
End Function