Consulting - Quality

Difference makes the DIFFERENCE

Categorised Menu List

Connect to access Database

Sample Code

Private Sub prcGetData()
On Error GoTo errHandler

    Dim cnt As ADODB.Connection
    Dim rstGetData As ADODB.Recordset
    Dim stConn As String
    Dim wbBook As Workbook
    Dim wsSheet1 As Worksheet

    Dim intRecCnt As Integer
    
    Set cnt = New ADODB.Connection
    Set rstGetData = New ADODB.Recordset
    Set wbBook = ThisWorkbook
    Set wsSheet1 = wbBook.Worksheets("Sheet1")
    
    'strDBPath = "D:\Users\abcd_1234\TestAP.mdb"
    strDBPath = "\\accounts_payable\processing\team work\today's work\TestAP.mdb"
    stConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & ";"
     
    'sqlOnDate = "Select * from tblWorkTable where WDate = #" & Me.rtxtOnDate.Text & "#"
    'sqlFromToDate = "Select * from tblWorkTable where WDate between #" & Me.rtxtFrmDate.Text & "# and #" & Me.rtxtToDate.Text & "#"
     
    wsSheet1.Range("A2..Z20000").Clear
    Range("A2").Select
     
    With cnt
        .Open (stConn) 'Open the connection.
        .CursorLocation = adUseClient 'Necessary to disconnect the recordset.
    End With
         
    'With rstGetData
        If Me.roptDate.Value Then
            If rstGetData.State = adStateClosed Then rstGetData.Open sqlOnDate, cnt 'Create the recordset.
        ElseIf Me.roptRange.Value Then
            If rstGetData.State = adStateClosed Then rstGetData.Open sqlFromToDate, cnt
        End If
            Set rstGetData.ActiveConnection = Nothing  'Disconnect the recordset.
    'End With
    
    rstGetData.MoveLast
    rstGetData.MoveFirst
    intRecCnt = rstGetData.RecordCount
    If intRecCnt = 0 Then
        MsgBox "No data retrieved for the selected date / Date Range... select another value", vbInformation + vbOKOnly, "No data..."
        Exit Sub
    Else
        MsgBox "Number of records retrieved from database are.. " & Str(intRecCnt), vbInformation + vbOKOnly, "Data..."
    End If
    
    
    With wsSheet1
        .Cells(2, 1).CopyFromRecordset rstGetData   '........... Copy the 1st recordset.
        '.Cells(2, 2).CopyFromRecordset rst2        '........... Copy the 2nd recordset.
    End With
     'Release objects from the memory.
    rstGetData.Close
    Set rstGetData = Nothing
    
    cnt.Close
    Set cnt = Nothing

errHandler:
    Select Case Err.Number
        Case 0
            Exit Sub
        Case 3021
            MsgBox "No Data retreived from database, please select another date range...", vbInformation + vbOKOnly, "prcGetData..."
            Exit Sub
        Case Else
            MsgBox Str(Err.Number) & " " & Err.Description, vbQuestion + vbOKOnly, "prcGetData..."
            Exit Sub
    End Select
End Sub