Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMS As Long)
Private Sub Command1_Click()
Dim accObj As Access.application, Msg As String
Dim application As String, dbs As String, workgroup As String
Dim user As String, password As String, cTries As Integer
Dim x
' This is the default location of Access
application = "C:\Program Files\Microsoft Office\Office\MSACCESS.EXE"
' Use the path and name of a secured MDB on your system
dbs = "C:\TestDatabase.mdb"
' This is the default workgroup
workgroup = "C:\Windows\System\System.mdw "
user = "Admin" ' Use a valid username
password = "Mypassword" ' and correct password
x = Shell(application & " " & Chr(34) & dbs & Chr(34) & " /nostartup /user " & user & _
" /pwd " & password & " /wrkgrp " & Chr(34) & workgroup & Chr(34), vbMinimizedFocus)
On Error GoTo WAITFORACCESS
Set accObj = GetObject(, "Access.Application")
' Turn off error handling
On Error GoTo 0
' You can now use the accObj reference to automate Access
Msg = "Access is now open. You can click on Microsoft Access "
Msg = Msg & "in the Taskbar to see that your database is open."
Msg = Msg & vbCrLf & vbCrLf & "When ready, click OK to close."
MsgBox Msg, , "Success!"
accObj.CloseCurrentDatabase
accObj.Quit
Set accObj = Nothing
MsgBox "All Done!", vbMsgBoxSetForeground
Exit Sub
WAITFORACCESS: ' <--- This line must be left-aligned.
' Access isn't registered in the Running Object Table yet, so call
' SetFocus to take focus from Access, wait half a second, and try
' again. If you try five times and fail, then something has probably
' gone wrong, so warn the user and exit.
SetFocus
If cTries < 5 Then
cTries = cTries + 1
Sleep 500 ' wait 1/2 seconds
Resume
Else
MsgBox "Access is taking too long. Process ended.", _
vbMsgBoxSetForeground
End If
End Sub