VBA code to handle Access Imports and Query

From ExeclExperts.com

VBA code to handle Access Imports and Query:

Paste the following code in a general module

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