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

   ' 测试数据库是否以独占方式打开
   If cn.Mode <> 12 Then
      MsgBox "老兄,要改密码先的把数据库独霸(独占方式打开)了才行", vbCritical
      Exit Sub
   End If
     
RetryPassword:
   newpassword = InputBox("劳您贵手,打个密码进来吧", "老兄,可要记住你的密码阿!" _
        , "新的数据库密码")

找不到原作者名,请作者看到后与我联系.
   
   Select Case newpassword
   
   ' 这里,你如果按了取消
   
    Case "新的数据库密码"
        MsgBox "没有密码,俺不干"
        Exit Sub
        
   ' 你按了ok
   
    Case ""
       NotValid = MsgBox("没密码俺不干" & Chr(10) & Chr(13) & _
       "真的决定改了吗?", vbCritical + vbYesNo)
       If NotValid = 6 Then
        GoTo RetryPassword
       Else
        Exit Sub
       End If
       
    
    Case Else
       sqlExecStr = "ALTER Database Password " & newpassword & "``"
       CurrentProject.Connection.Execute sqlExecStr
       MsgBox "Okey"
                     
    End Select
      
End Sub

'下面是去掉密码

Sub ResetDBPassword()
   Dim cn As ADODB.Connection
   Dim sqlExecStr As String
   Dim ResetQuestion As Integer
   
   Set cn = CurrentProject.Connection
   On Error Resume Next
   
   ' 测试数据库是否以独占方式打开
   If cn.Mode <> 12 Then
      MsgBox "老兄,要改密码先的把数据库独霸(独占方式打开)了才行", vbCritical
      Exit Sub
   End If
   ResetQuestion = MsgBox("重设吗" & _
            Chr(10) & Chr(13) & "空密码喽", vbQuestion + vbYesNo, _
            "去掉密码")

    
    If ResetQuestion = 6 Then
        sqlExecStr = "ALTER DATABASE PASSWORD `` DBPassword"
        CurrentProject.Connection.Execute sqlExecStr
        MsgBox "没了"
    Else
        MsgBox "还是有密码"
        Exit Sub
    End If

End Sub