Class: ADOConnJet in Category Access/Jet Databases : Database from Total Visual SourceBook

' Example of CADOConnJet
'
' To try this example, do the following:
' 1. Create a new user form in your project.
' 2. Create the following command buttons
'       cmdOpenConn
'       cmdUsers
' 3. Paste this code into the form's module

Private Const mcstrSampleDatabase As String = "C:\Total Visual SourceBook 2013\Samples\Sample.mdb"
Private Const mcstrTable As String = "Categories"
Private WithEvents mclsADOConnJet As CADOConnJet

#If VBA7 Then
  Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#Else
  Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#End If

Private Sub cmdOpenConn_Click()
  ' Comments: This example creates the CADOConnJet object. The connection is made asynchronously.
  '           When the connection is complete, the ConnectComplete event is used to open a recordset using the connection

  Dim strError As String

  Debug.Print "Connecting..."

  Set mclsADOConnJet = New CADOConnJet

  With mclsADOConnJet
    ' Use ACE provider for Access 2007 or later to support ACCDB and MDB databases
    .JetVersion = acjVersion12

    .UserID = "Admin"
    .Password = ""
    .CursorLocation = adUseServer
    .DataSource = mcstrSampleDatabase
    .Mode = adModeRead
    strError = .OpenConnection
  End With

  If strError = "" Then
    MsgBox "Database successfully opened"
  Else
    MsgBox strError
  End If

End Sub

Private Sub cmdUsers_Click()
  ' Comments: Display the current users in the database

  Dim clsJetConnection As New CADOConnJet
  Dim strError As String
  Dim intUsers As Integer
  Dim strUserInfo As String

  MsgBox "Before running this routine, open the database: " & vbCrLf & mcstrSampleDatabase & vbCrLf & " in another instance of Access to simulate another user."

  With clsJetConnection
    ' Set the database version to ACE provider for Access 2007 or later to support ACCDB and MDB databases
    .JetVersion = acjVersion12

    strError = .OpenDatabase(mcstrSampleDatabase)
    If strError = "" Then
      ' See how many connections there are to the database
      intUsers = .ADOUserCount()

      strUserInfo = "Current user count: " & intUsers & vbCrLf & _
                    "List of users: " & .ADOUserComputersToString() & vbCrLf & _
                    "List of user details: " & .ADOUserRosterToString()
      MsgBox strUserInfo

      If intUsers > 1 Then
        If .ADOPassiveShutdown(True) Then
          ' For it to remain active, the connection variable cannot be closed
          ' Here, we keep it open until there's only one connection left
          MsgBox "This code waits until all other copies of the database are closed."

          Do Until intUsers = 1
            intUsers = .ADOUserCount()

            ' Pause a second and check again
            WaitSeconds 1
          Loop

          MsgBox "All other users have exited the database"
        End If
      Else
        MsgBox "No other users are in the database"
      End If
    Else
      MsgBox strError
    End If

    .CloseConnection

  End With

  Set clsJetConnection = Nothing
End Sub

Private Sub Form_Load()
  Me.cmdOpenConn.Caption = "Test OpenConnection"
  Me.cmdUsers.Caption = "Test MultiUser"
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set mclsADOConnJet = Nothing
End Sub

Private Sub mclsADOConnJet_ConnectComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
  ' Comments: The procedure which is called when the class raises the ConnectComplete event. This is where you can update the user interface.

  Dim rst As ADODB.Recordset
  Dim strSQL As String

  strSQL = "SELECT * FROM " & mcstrTable

  If pError Is Nothing Then
    If pConnection.state = adStateOpen Then
      Debug.Print "Connect String: " & pConnection.ConnectionString
      Set rst = pConnection.Execute(strSQL)
      If Not rst.EOF Then
        Do Until rst.EOF
          Debug.Print rst(1)
          rst.MoveNext
        Loop
      End If
    Else
      Debug.Print "Connection failure, invalid state"
      MsgBox "Unable to open the connection"
    End If
  Else
    Debug.Print "Connection failure"
    MsgBox "Unable to open the connection"
  End If

End Sub

' Dependencies: (Declarations)
Private Sub WaitSeconds(intSeconds As Integer)
  ' Comments: Waits for a specified number of seconds
  ' Params  : intSeconds    Number of seconds to wait
  ' Source  : Total Visual SourceBook

  On Error GoTo PROC_ERR

  Dim datTime As Date

  datTime = DateAdd("s", intSeconds, Now)

  Do
    ' Yield to other programs (better than using DoEvents alone which eats up all the CPU cycles)
    Sleep 100
    DoEvents
  Loop Until Now >= datTime

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , "modDateTime.WaitSeconds"
  Resume PROC_EXIT
End Sub

The source code in Total Visual Sourcebook includes modules and classes for Microsoft Access, Visual Basic 6 (VB6), and Visual Basic for Applications (VBA) developers. Easily add this professionally written, tested, and documented royalty-free code into your applications to simplify your application development efforts.

Total Visual SourceBook is written for the needs of a developer using a source code library covering the many challenges you face. Countless developers over the years have told us they learned some or much of their development skills and tricks from our code. You can too!

Additional Resources

• List of All Modules in Total Visual SourceBook
• List of All Code Categories in Total Visual SourceBook
• Sample Module Code from Total Visual SourceBook (Example of Date, Time and Age Calculations)