(Solved) – Asynchronous Recordset query using ADODB


I’m trying to figure out how I can run database queries asynchronously that don’t block interacting with Excel while running.

I have searched multiple places and the best I have managed to do still freezes Excel for some time as it runs.

I added a button that runs CallAsynchronous, I press it and try to select cells with the mouse to test if Excel is frozen or not. It selects one and then it doesn’t anymore until the code finishes.


Option Explicit

Public Sub CallAsynchronous()

  Excel.Application.OnTime VBA.Now   VBA.TimeValue("0:00:01"), "ConnectDatabaseServer"

End Sub

Private Sub ConnectDatabaseServer()

  Const ConnectionString As String = "Driver={Oracle in OraClient11g_home1}; Server=Server; Dbq=Dbq"
  Const UserIdentifier As String = "User"
  Const Password As String = "Pass"
  Const Source As String = "select 'long query' from dual"

  Dim Connection As ADODB.Connection
  Dim ConnectionClass As VBAProject.ConnectionClass

  Set Connection = New ADODB.Connection
  Connection.Open ConnectionString, UserIdentifier, Password
  Set ConnectionClass = New VBAProject.ConnectionClass
  ConnectionClass.Execute Connection, Source
  Set Connection = Nothing

End Sub

Class module ConnectionClass:

Option Explicit

Private WithEvents Recordset As ADODB.Recordset

Private Sub Recordset_FetchComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)

  Const StartingColumn As Long = 1
  Const StartingRow As Long = 1
  Const HeaderHeight As Long = 1

  Dim Column As Long

  For Column = StartingColumn To StartingColumn - 1   Recordset.Fields.Count
    Sheet1.Cells(StartingRow, Column).Value = Recordset.Fields(Column - StartingColumn).Name
  If Recordset.RecordCount > 0 Then
    Sheet1.Cells(StartingRow   HeaderHeight, StartingColumn).CopyFromRecordset Recordset
  End If
  Sheet1.Columns(StartingColumn).Resize(, StartingColumn   Recordset.Fields.Count).AutoFit

End Sub

Public Sub Execute(ByVal Connection As ADODB.Connection, ByVal Source As String)

  Set Recordset = New ADODB.Recordset
  Recordset.CursorLocation = ADODB.CursorLocationEnum.adUseClient
  Recordset.Open Source, Connection, Options:=ADODB.CommandTypeEnum.adCmdText   ADODB.ExecuteOptionEnum.adAsyncFetch
  Do While Recordset.State = ADODB.ObjectStateEnum.adStateOpen
  Set Recordset = Nothing

End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *