79741547

Date: 2025-08-20 20:20:33
Score: 0.5
Natty:
Report link

I have updated the sub posted by @xiaoyaosoft using the CompactDatabase method as suggested by @June7. Tested for all combinations of setting changing, or removing a password, and also encrypting or decrypting the database. I didn't look at the database files at a low level after any of these changes to see what effect the encryption process has - I merely verified that it could be opened and read in Access after each change.

' Procedure : Set_DBPassword
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Change the password of any given database
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sDBName   : Full path and file name with extension of the database to modify the pwd of
' sOldPwd   : Existing database pwd - use "" if db is unprotected
' sNewPwd   : New pwd to assign - Optional, leave out if you wish to remove the
'             existing pwd
' bEncrypt  : Encrypt the database if adding a new password, or decrypt it if removing
'             (has no effect if only changing an existing password)
'
' Usage:
' ~~~~~~
' Set a pwd on a db which never had one
' Set_DBPassword "C:\Users\Daniel\Desktop\db1.accdb", "", "test"
'
' Clear the password on a db which previous had one
' Set_DBPassword "C:\Users\Daniel\Desktop\db1.accdb", "test", "" 'Clear the password
'
' Change the pwd of a pwd protected db
' Set_DBPassword "C:\Users\Daniel\Desktop\db1.accdb", "test", "test2"
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 2         2025-Aug-20                 Made work for to or from blank password (by MEM)
' 1         2012-Sep-10                 Initial Release
'---------------------------------------------------------------------------------------
Private Sub Set_DBPassword(sDBName As String, sOldPwd As String, Optional sNewPwd As String = "", Optional bEncrypt As Boolean = False)
  On Error GoTo Error_Handler
  Dim db              As DAO.Database

  'Password can be a maximum of 20 characters long
  If Len(sNewPwd) > 20 Then
    MsgBox "Your password is too long and must be 20 characters or less." & _
           "  Please try again with a new password", vbCritical + vbOKOnly
    GoTo Error_Handler_Exit
  End If

    'Could verify pwd strength
    'Could verify ascii characters

  If sOldPwd = vbNullString And sNewPwd <> vbNullString Then          ' use temporary file
    If bEncrypt Then
      DBEngine.CompactDatabase sDBName, sDBName & ".$$$", dbLangGeneral & ";pwd=" & sNewPwd, dbEncrypt
    Else
      DBEngine.CompactDatabase sDBName, sDBName & ".$$$", dbLangGeneral & ";pwd=" & sNewPwd
    End If
    Kill sDBName
    Name sDBName & ".$$$" As sDBName

  ElseIf sOldPwd <> vbNullString And sNewPwd = vbNullString Then      ' use temporary file database
    If bEncrypt Then
      DBEngine.CompactDatabase sDBName, sDBName & ".$$$", dbLangGeneral & ";pwd=" & sNewPwd, dbDecrypt, ";pwd=" & sOldPwd
    Else
      DBEngine.CompactDatabase sDBName, sDBName & ".$$$", dbLangGeneral & ";pwd=" & sNewPwd, , ";pwd=" & sOldPwd
    End If
    Kill sDBName
    Name sDBName & ".$$$" As sDBName
  
  Else
    Set db = OpenDatabase(sDBName, True, False, ";PWD=" & sOldPwd)    'open the database in exclusive mode
    db.NewPassword sOldPwd, sNewPwd    'change the password
  
  End If

Error_Handler_Exit:
  On Error Resume Next
  kill sDBName & ".$$$"
  db.Close    'close the database
  Set db = Nothing
  Exit Sub

Error_Handler:
  'err 3704 - not able to open exclusively at this time, someone using the db
  'err 3031 - sOldPwd supplied was incorrect
  'err 3024 - couldn't locate the database file
  MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
         "Error Number: " & Err.Number & vbCrLf & _
         "Error Source: Set_DBPassword" & vbCrLf & _
         "Error Description: " & Err.Description, _
         vbCritical, "An Error has Occurred!"
  Resume Error_Handler_Exit
End Sub
'from :https://www.devhut.net/ms-access-vba-change-database-password/
Reasons:
  • Long answer (-1):
  • Has code block (-0.5):
  • User mentioned (1): @xiaoyaosoft
  • User mentioned (0): @June7
  • Self-answer (0.5):
  • Low reputation (0.5):
Posted by: Mark Moulding