How to encrypt Access with password using code?

Question

I created a Deploy Access file which I use to deploy my production Access file. This re-links tables to production SQL server, incorporates disabling use of Shift, add new version number.... I need also encrypt the production Access file with a password. This should be done using code in my Deploy Access file but I cannot find a way to do it. Any ideas? Thanks.

Answer 1

Try this function:

Public Function SetDatabasePassword(strDatabasePath As String, Optional pNewPassword As Variant, Optional pOldPassword As Variant) As String
    On Error GoTo SetDatabasePassword_Error
    DoCmd.Hourglass True
    Const cProvider = "Microsoft.ACE.OLEDB.12.0"
    Dim cnn As ADODB.Connection
    Dim strNewPassword As String
    Dim strOldPassword As String
    Dim strCommand As String
    Dim strResult As String

    ' If a password is not specified (IsMissing), ' the string is "NULL" WITHOUT the brackets
    If IsMissing(pNewPassword) Then
        strNewPassword = "NULL"
    Else
        strNewPassword = "[" & pNewPassword & "]"
    End If
    
    If IsMissing(pOldPassword) Then
        strOldPassword = "NULL"
    Else
        strOldPassword = "[" & pOldPassword & "]"
    End If
    
    strCommand = "ALTER DATABASE PASSWORD " & strNewPassword & " " & strOldPassword & ";"
    
    Set cnn = New ADODB.Connection
    With cnn
        .Mode = adModeShareExclusive
        .Provider = cProvider
        If Not IsMissing(pOldPassword) Then
            .Properties("Jet OLEDB:Database Password") = pOldPassword
        End If
        .Open "Data Source=" & strDatabasePath & ";"
        .Execute strCommand
    End With
    strResult = "Password Set"
ExitProc_:
    On Error Resume Next
    cnn.Close
    Set cnn = Nothing
    SetDatabasePassword = strResult

    DoCmd.Hourglass False
    Exit Function

SetDatabasePassword_Error:
    DoCmd.Hourglass False
    If Err.Number = -2147467259 Then
        strResult = "An error occured"
    ElseIf Err.Number = -2147217843 Then
        strResult = "Invalid password"
    Else
        strResult = Err.Number & " " & Err.Description
    End If
    Resume ExitProc_
    Resume ' use for debugging
End Function