VB6 Adding or removing a database password using DAO

Question

I have a large VB6 application (I know - it's ~750 kLOC, and I do have an exit strategy, but I need to limp along with this a bit longer) using DAO (higher performance for single user than ADO). I have a need to "encrypt" the databases (the Access password is adequate). I've updated the application so that it works fine with a database to which I've assigned a password using the Access office application, and my program can programmatically create databases with a password. The problem is that I need to be able to add a password to an existing database that doesn't have one, or remove one from a database that does.

I used the .NewPassword method to successfully change the password of a database that already has one - it worked as expected. Its syntax (neither parameter is optional) is:

 object.NewPassword oldpassword, newpassword

In order to add a password, I thought it would be a simple case of using vbNullString for the oldpassword parameter, but VB throws error 3031 "Not a valid password". The same thing happens when I try to remove a password by using vbNullString for newpassword.

The documentation (MSDN and on-line) has the cryptic statement If a database has no password, Microsoft Jet will automatically create one by passing a zero-length string ("") for the old password., but that's not what's happening (plus the syntax of that statement seems backwards...).

tl;dr: How to I programmatically using DAO assign a password to a database or remove one?

Thanks!

Answer 1

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/