Public g_objConnection As ADODB.Connection
Public Const gc_strDBPath As String = "C:\Test.mdb"
 
Function blnConnectDatabase(strPath As String, strDBPass As String) As Boolean
'    If blnFileExists(strPath) = False Then
'        GoTo ErrH
'        Exit Function
'    End If
    Set g_objConnection = New ADODB.Connection
    On Error GoTo ErrH
    g_objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
        strPath & ";Jet OLEDB:Database Password=" & strDBPass & ";"
    On Error GoTo 0
    blnConnectDatabase = True
    GoTo ExitH
ErrH:
    blnConnectDatabase = False
    Set g_objConnection = Nothing
ExitH:
    Application.StatusBar = False
End Function
 
Function blnTableExistsInDB(strTableName As String) As Boolean
    Dim rst         As ADODB.Recordset
    Dim strTbl      As String
 
    strTbl = strTableName
    Call blnConnectDB
    Set rst = g_objConnection.OpenSchema(adSchemaTables)
 
    If Left(strTbl, 1) = "[" And Right(strTbl, 1) = "]" Then
        strTbl = Mid(strTbl, 2, Len(strTbl) - 2)
    End If
 
    rst.Filter = "TABLE_TYPE='TABLE' and TABLE_NAME='" & strTbl & "'"
    On Error Resume Next
    blnTableExistsInDB = (UCase(rst.Fields("TABLE_NAME").Value) = UCase(strTbl))
    On Error GoTo 0
    If Err.Number <> 0 Then blnTableExistsInDB = False
    Set rst = Nothing
End Function
 
Function ExecuteDBQuery(strQuery As String, Optional rngTarget As Range, Optional blnHeader As Boolean) As ADODB.Recordset
    Dim objRecordset                As ADODB.Recordset
    Dim intColIndex                 As Integer
    Dim lngRowOffset                As Long
 
    On Error GoTo ErrH
    Call blnConnectDB
 
    If Not rngTarget Is Nothing Then
        Set rngTarget = rngTarget.Cells(1, 1)
    End If
    Set objRecordset = New ADODB.Recordset
 
    With objRecordset
 
        .CursorLocation = adUseClient
        '.Open strQuery, g_objConnection, adOpenForwardOnly, adLockReadOnly ', adCmdText
        .Open strQuery, g_objConnection, adOpenDynamic, adLockOptimistic ', adCmdText
        
        If Not rngTarget Is Nothing Then
            If blnHeader = True Then
                For intColIndex = 0 To objRecordset.Fields.Count - 1 'field names
                    rngTarget.Cells(1, intColIndex + 1).NumberFormat = "@"
                    rngTarget.Cells(1, intColIndex + 1).Value = .Fields(intColIndex).Name
                    rngTarget.Cells(1, intColIndex + 1).Font.Bold = True
                Next intColIndex
                lngRowOffset = 1
            Else  'Without field names
                lngRowOffset = 0
            End If
 
            If Application.Version < 12 And .RecordCount + rngTarget.Cells(lngRowOffset + 1, 1).Row > 65535 Then
                MsgBox "Records upto row number 65535 can be accommodated. Rest will be ignored.", vbInformation, "Import"
            ElseIf Application.Version >= 12 And objRecordset.RecordCount + rngTarget.Cells(lngRowOffset + 1, 1).Row > 1048576 Then
                MsgBox "Records upto row number 1048576 can be accommodated. Rest will be ignored.", vbInformation, "Import"
            End If
            rngTarget.Cells(lngRowOffset + 1, 1).CopyFromRecordset objRecordset ' the recordset data
        End If
    End With
    Set ExecuteDBQuery = objRecordset
ErrH:
    Set objRecordset = Nothing
    If Err.Number <> 0 Then
        'MsgBox Err.Description, vbCritical, "Error"
        'MsgBox "Database Query Error"
    End If
End Function
 
Sub DropTable(ParamArray strTableName() As Variant)
    Dim x As Integer
    For x = LBound(strTableName) To UBound(strTableName)
        If blnTableExistsInDB(CStr(strTableName(x))) = True Then
            Call ExecuteDBQuery("Drop Table " & CStr(strTableName(x)))
        End If
    Next x
End Sub
 
Function blnConnectDB() As Boolean
    Dim blnCon As Boolean
    blnCon = True
    If g_objConnection Is Nothing Then
        blnCon = blnConnectDatabase(gc_strDBPath, "")
    ElseIf Not g_objConnection.State = 1 Then
        blnCon = blnConnectDatabase(gc_strDBPath, "")
    End If
 
    blnConnectDB = blnCon
End Function
 
Sub CompactDB()
    Dim lngRes As Long
    Call CloseDB
    lngRes = DatabaseCompact(gc_strDBPath)
    If lngRes = 0 Then
        'MsgBox "Succeeded in compacting database...", vbInformation
    Else
        'MsgBox Error(lngRes)
        Application.StatusBar = "Unable to clean database..."
    End If
End Sub
 
Function DatabaseCompact(strDBPath As String, Optional strDBPass As String = "") As Long
On Error GoTo ErrFailed
    'Delete the existing temp database
    If Len(Dir$(strDBPath & ".tmp")) Then
        VBA.Kill strDBPath & ".tmp"
    End If
 
    With CreateObject("JRO.JetEngine")
        If strDBPass = "" Then 'DB without password
            .CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & ".tmp;Jet OLEDB:Encrypt Database=True"
        Else             'Password protected db
            .CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & ";Jet OLEDB:Database Password=" & strDBPass, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & ".tmp;Jet OLEDB:Encrypt Database=True;Jet OLEDB:Database Password=" & strDBPass
        End If
    End With
On Error GoTo 0
    VBA.Kill strDBPath 'Delete the existing database
    Name strDBPath & ".tmp" As strDBPath 'Rename the compacted database
ErrFailed:
    DatabaseCompact = Err.Number
End Function
 
Sub CloseDB()
    If Not g_objConnection Is Nothing Then
        If g_objConnection.State = 1 Then g_objConnection.Close
    End If
    Set g_objConnection = Nothing
End Sub