Option Explicit
Sub ADOAddPW()
   Dim cn As ADODB.Connection
   Dim newpassword As String
   Dim NotValid As Integer
   Dim sqlExecStr As String

   Set cn = CurrentProject.Connection
   On Error Resume Next

   ' Test to see if the database is open exclusively.
   If cn.Mode <> 12 Then
      MsgBox "Your database is not opened exclusively", vbCritical
      Exit Sub
   End If
    
RetryPassword:
   newpassword = InputBox("Please enter new database password", "Database Password" _
        , "New Database Password")

' Select case for inputbox.
  
   Select Case newpassword
  
   ' Case where the cancel button was pressed.
  
    Case "New Database Password"
        MsgBox "No Database password set"
        Exit Sub
       
   ' Case where the OK button was pressed without entering data.
  
    Case ""
       NotValid = MsgBox("You have not entered a valid password, or clicked the cancel button" & Chr(10) & Chr(13) & _
       "Do you want to change the database password?", vbCritical + vbYesNo)
       If NotValid = 6 Then
        GoTo RetryPassword
       Else
        Exit Sub
       End If
      
    'If any data is entered other than the default value.
   
    Case Else
       sqlExecStr = "Alter Database Password " & newpassword & "``"
       CurrentProject.Connection.Execute sqlExecStr
       MsgBox "Database password has been set"
                    
    End Select
     
End Sub