'variáveis gerais
Dim strPassword As String     'A senha para abrir ou definir o novo banco de dados
Dim strSource As String        'Caminho e nome do arquivo da fonte de dados
Private Sub Command1_Click()

On Error Resume Next
'fecha o banco de dados se ele estiver aberto
cnn.Close
On Error GoTo 0

strSource = App.Path & "\TestePassword.mdb"

'verifica se o arquivo .mdb já esta presente
If Dir$(strSource) <> "" Then
   If MsgBox(strSource & " já existe. Posso sobreescrever o arquivo ?", vbQuestion + vbYesNo) = vbNo Then
       Exit Sub
   Else
       Kill (strSource)
   End If
End If

'Pega a senha
strPassword = InputBox("Informe a senha para o novo banco de dados. Deixe em branco para usa sem senha")
Set cat = New ADOX.Catalog
cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strSource & ";Jet OLEDB:database Password=" & strPassword

Set tbl = New ADOX.Table
tbl.Name = "Tabela1"
' Inclui um anova tabela a coleção Tables do banco de dados
cat.Tables.Append tbl

With tbl
   ' Cria os campos e os anexa a coleção Columns do novo objeto Table
   Set col = New ADOX.Column
   With col
      .Name = "Campo1"
      .DefinedSize = 50
      .Type = adVarWChar
      .SortOrder = adSortAscending
    End With
    .Columns.Append col
    Set col = Nothing
End With

'define campo permitindo dados de comprimento zero
tbl.Columns("Campo1").Properties("Jet OLEDB:Allow Zero Length") = True

'inclui alguns dados
Set cnn = New ADODB.Connection
cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strSource & ";Persist Security Info=False"
cnn.Properties("Jet OLEDB:database Password").Value = strPassword
cnn.Open
cat.ActiveConnection = cnn

Set rst = New ADODB.Recordset

rst.Open "Tabela1", cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect

rst.AddNew
rst!Campo1 = "campo teste"
rst.Update

rst.Close

MsgBox "Banco de dados com senha criado com sucesso ", vbInformation, "Banco de dados com senha"

End Sub