Disconnected Recordset

By: Hermawih Hasan

Here are an example of how you can populate combo and list box control using disconnected recordset. Connection is expensive resources especially for multi user application. For that kind of application it is better to connect to database, get the data and disconnect from database. Data is now in memory cache. Here I have a sample how you can get data from different database and put the data in memory cache and put the data in combo or list box. In this example I have following objects.

• Backend Database, dtaAccessSample.mdb with only one tabel tblCust:

  tblCust
  CustID	Name	Company	Address
  1	Santo Daya	PT Jaga Raga	Bandung
  2	Santi Jaya	CV Daya Makmur	Jakarta
  3	Karlina Mukti	SOFTDATA International	Los Angeles

• Front End Application, AccessControl.mdb:
  • A form with 5 controls:
    • Combo box cboCust.
    • List box lstCust.
    • cmdGetCombo to get values and put them into combo cboCust.
    • cmdGetCustList to get values and put them into lstCust.
    • btnCancel to close the form.
  • One modul basConnection:
    • GetConnection - get connection to backend database.
  • Two Class Module:
    • CcustDS - Data Structure for display.
    • Ccusts - Load Customers.
• Coding for form:

  Option Compare Text
Option Explicit
Private Const mcstrMod As String = "frmControl"

  Private Sub btnCancel_Click()
    DoCmd.Close acForm, Me.Name
  End Sub

  Private Sub cmdGetCombo_Click()
    'Get data for combo

    On Error GoTo Err_Trap
    Const cstrProc As String = ("cmdGetCombo_Click")

    Dim oCust As CCusts
    Dim iint As Integer
    Dim strCust As String

    Set oCust = New CCusts

    oCust.Load

    Me!cboCust = vbNullString
    For iint = 1 To oCust.count
    strCust = strCust & ";" & oCust.Item(iint).CustID & ";" & oCust.Item(iint).Name
    Next iint
    Me!cboCust.RowSource = Mid(strCust, 2)
    Set oCust = Nothing

  Err_Exit:
    Exit Sub
  Err_Trap:
    Select Case Err.Number
    Case Else
      MsgBox "Error in   : " & mcstrMod & "." & cstrProc _
      & vbCrLf & "Error Number : " & Err.Number _
      & vbCrLf & "Description : " & Err.Description, vbCritical, "Community Sample"
    End Select
    Resume Err_Exit
  End Sub

  Private Sub cmdGetCustList_Click()

    On Error GoTo Err_Trap
    Const cstrProc As String = ("cmdGetCustList_Click")

    Dim oCust As CCusts
    Dim iint As Integer

    Set oCust = New CCusts
    oCust.Load
    Me!lstCust.RowSource = vbNullString
    For iint = 1 To oCust.count
    Me!lstCust.AddItem oCust.Item(iint).CustID & ";" & _
    oCust.Item(iint).Name & ";" & oCust.Item(iint).Company
    Next iint
    Set oCust = Nothing

    Err_Exit:
      Exit Sub
      Err_Trap:
        Select Case Err.Number
          Case Else
            MsgBox "Error in   : " & mcstrMod & "." & cstrProc _
            & vbCrLf & "Error Number : " & Err.Number _
            & vbCrLf & "Description : " & Err.Description, vbCritical, "Community Sample"
        End Select
      Resume Err_Exit

  End Sub

• Coding for basConnection:

  Option Compare Text
Option Explicit
Private Const mcstrMod As String = "basConnection"
Public Function GetConnection(ByRef cnn As ADODB.Connection) As Boolean

    'Purpose : Connect to Database

  On Error GoTo Err_Trap
  Const cstrProc As String = ("GetConnection")

  With cnn
    .ConnectionString = CurrentProject.Path & "\dtaAccessSample.mdb"
    .ConnectionTimeout = 60
    .CursorLocation = adUseClient
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .Open
  End With

  If cnn.State = adStateOpen Then
    GetConnection = True
  Else
    GetConnection = False
  End If

  Err_Exit:
  Exit Function
Err_Trap:
  Select Case Err.Number
    Case Else
      MsgBox "Error in   : " & mcstrMod & "." & cstrProc _
      & vbCrLf & "Error Number : " & Err.Number _
      & vbCrLf & "Description : " & Err.Description, vbCritical, "Sample Coding"
  End Select
  Resume Err_Exit
End Function

• Coding for CcustDS:

  Option Explicit
Option Compare Text

  Private Type PropsDS
    CustID As Long
      Name As String
      Company As String
      Address As String
  End Type

  Private dtaProps As PropsDS

  Public Property Get CustID() As Long
    CustID = dtaProps.CustID
  End Property

  Public Property Get Name() As String
    Name = Trim$(dtaProps.Name)
  End Property

  Public Property Get Company() As String
    Company = Trim$(dtaProps.Company)
  End Property

  Public Property Get Address() As String
    Address = Trim$(dtaProps.Address)
  End Property

  Friend Property Let CustID(value As Long)
    dtaProps.CustID = value
  End Property

  Friend Property Let Name(value As String)
    dtaProps.Name = value
  End Property

  Friend Property Let Company(value As String)
    dtaProps.Company = value
  End Property

  Friend Property Let Address(value As String)
  dtaProps.Address = value
End Property

• Coding for Ccusts
:

Option Explicit
Option Compare Text

Private Const mcstrMod As String = "CCusts"
Private mcolDisplay As Collection
Private Sub Class_Initialize()
  Set mcolDisplay = New Collection
End Sub

Public Function count() As Long
  count = mcolDisplay.count
End Function

Public Function Item(ByVal Index As Variant) As CCustDS
  Set Item = mcolDisplay(Index)
End Function

Friend Function Load() As Boolean
  'Load Customers

Const cstrProc As String = "Load"

On Error GoTo Err_Trap

Dim blnGetRec As Boolean
Dim rst As ADODB.Recordset
Dim cnn As ADODB.Connection
Dim objDisplay As CCustDS

Load = False
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset

Load = GetConnection(cnn)

  If Not Load Then GoTo Err_Exit
  rst.Open "spCusts", cnn, adOpenKeyset, adLockPessimistic, adCmdTable

rst.MoveFirst

Do While Not rst.EOF
  Set objDisplay = New CCustDS
  With objDisplay
    If Not IsNull(rst.Fields!CustID) Then .CustID = rst.Fields!CustID
    If Not IsNull(rst.Fields!Company) Then .Company = rst.Fields!Company
    If Not IsNull(rst.Fields!Address) Then .Address = rst.Fields!Address
    If Not IsNull(rst.Fields!Name) Then .Name = rst.Fields!Name
    mcolDisplay.Add objDisplay
    Set objDisplay = Nothing
  End With

rst.MoveNext
Loop

Load = True

Err_Exit:
  rst.Close
  Set rst = Nothing
  Set cnn = Nothing
  Exit Function
Err_Trap:
  Select Case Err.Number
    Case Else
      MsgBox "Error in   : " & mcstrMod & "." & cstrProc _
      & vbCrLf & "Error Number : " & Err.Number _
      & vbCrLf & "Description : " & Err.Description, vbCritical, "Community Sample"
  End Select
Resume Err_Exit
End Function

• To see sample, get this AccessSample.zip.