Question : Excel Instance Left in Memory after Access Automation

The following code leaves an Excel instance in memory, until VBA is "ended" on an artificial error halt ( like x = 1/0) or Access quits.  I would like the Excel instance to be made to go away when this routine ends.   This situation can be reproduced with:

Folder       C:\Test              containing:
1) Access mdb with Table1 only (any field in table OK), and a few records in Table1, and the code below
2) Excel workbook named Testwb.xls

XP Pro, Access 2002

'===================================================
Option Compare Database
Dim xlsDoc, xlsApp, EST_Data_File_Name1, Est_Data_Folder_path, eio, I

'========================Main Routine=======================================
Public Sub App_Test2()

'------initialize app, doc, and delete existing sheets
init_excel2

'-----import to Excel from Access   ==>>> COMMENTING THIS NEXT STATEMENT OUT REMOVES THE PROBLEM
'                                                             The querytable.add in this routine seems to be what creates the
'                                                             "hook" that won't let the last instance of Excel go away until
'                                                             Access quits or Access VBA ends
Insert_Data1

'------save the workbook
xlsDoc.Save

'----Now shut the whole thing off

'----This closes any open QueryTables, but doesn't seem to help
xlsApp.DisplayAlerts = False
For n1 = 1 To xlsDoc.Sheets.Count

start_conn_delete:
If xlsDoc.Sheets(n1).QueryTables.Count > 0 Then
    xlsDoc.Sheets(n1).QueryTables(xlsDoc.Sheets(n1).QueryTables.Count).Delete
    Else: GoTo after_conn_delete
    End If
GoTo start_conn_delete
after_conn_delete:

Next n1
xlsApp.DisplayAlerts = True
'-----------------------------------------------------


'------ close the Excel instance used for this app
    For n = 1 To xlsApp.Workbooks.Count
    If xlsApp.Workbooks(n).Name = EST_Data_File_Name1 Then
        Set xlsDoc = xlsApp.Workbooks(n)
        xlsApp.Quit
'        Set xlsApp = Nothing
    End If
    Next n

'------- close Excel completely if no other workbooks
If xlsApp.Workbooks.Count = 0 Then
    xlsApp.Quit
    Set xlsDoc = Nothing
    Set xlsApp = Nothing
    eio = False
    Set l = Nothing
End If

End Sub

'============================================================================
Public Sub init_excel2()                        'this initializes the Excel app and file
                                                         'may seem a little busy but handles several different cases

On Error GoTo ErrorHandler
EST_Data_File_Name1 = "Testwb.xls"
Est_Data_Folder_path = "C:\Test\"
EST_Data_File_Path1 = Est_Data_Folder_path & EST_Data_File_Name1

  If ExcelIsOpen Then                                               ' separate test function below
    'Excel is open, set xls to the open process:
    Set xlsApp = GetObject(, "Excel.Application")
    eio = True 'For use later in the ErrorHandler
  Else
    'Excel is not open, create a new process:
    Set xlsApp = CreateObject("Excel.Application")
    eio = False 'For use later in the ErrorHandler
  End If


Open_Check:
If xlsApp.Workbooks.Count = 0 Then GoTo Open_It
For n = 1 To xlsApp.Workbooks.Count
Debug.Print xlsApp.Documents(n).Name
If xlsApp.Documents(n).Name = EST_Data_File_Name1 Then
        Set xlsDoc = xlsApp.Documents(n)
        Exit Sub
    End If
Next n
GoTo Open_It
enderr:
a2 = 1

Open_It:
On Error GoTo DocErr
Set xlsDoc = xlsApp.Workbooks.Open(EST_Data_File_Path1)
GoTo Doc_Opened
DocErr:
MsgBox ("didn't find EST work file")
Exit Sub

Doc_Opened:

xlsApp.Visible = True

Exit Sub

ErrorHandler:
  If IsEmpty(xlsApp) = False Then
    'If eio = True then we re-used an existing Excel process so we don't want to
    'close it because we might lose data.
    'Else, if eio = False then we created a new Excel process, let's close it:
    If eio = False Then
      If IsEmpty(xlsApp) = False Then
        For l = 1 To xlsApp.Workbooks.Count 'Loop through all open xls workbooks and close them
                                         'without saving changes
          xlsApp.Workbooks(l).Close savechanges:=False
        Next l
        xlsApp.Quit 'Close the xls process
      End If
    End If
  End If
  Resume UnsetVars2 'Go back to cleanup the variables

UnsetVars2:
  Set xlsApp = Nothing
  eio = False
  Set l = Nothing
  Exit Sub


End Sub

'============================================================================
Private Function ExcelIsOpen()                    'Check to see if Excel is currently open, return True/False
  On Error GoTo ErrorHandler
 
  ExcelIsOpen = False
  Set xlsApp = GetObject(, "Excel.Application")
  ExcelIsOpen = True
UnsetVars:
  Set xlsApp = Nothing
  Exit Function
 
ErrorHandler:
  Resume UnsetVars
End Function
'============================================================================
Sub Insert_Data1()
'-----------------------------this does the import to Excel from Access
'-----------------------------this code was captured by recording an Excel macro and
                                     ' copying it from Excel VBA to Access VBA

    With ActiveSheet.QueryTables.Add(Connection:= _
        "ODBC;DSN=MS Access Database;DBQ=C:\Test\Testdb.mdb;DefaultDir=C:\Test;DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;" _
        , Destination:=Range("A1"))
        .CommandText = Array("SELECT * FROM `Table1`")
        .Name = "MS Access Database (not sharable)"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceConnectionFile = _
        "C:\Program Files\Common Files\ODBC\Data Sources\MS Access Database (not sharable).dsn"
        .Refresh BackgroundQuery:=False
    End With

End Sub

Answer : Excel Instance Left in Memory after Access Automation

Hi codequest,

I had a play with your code but got similar problems to what you report and could not figure out how to solve them. It was actually quit difficult because it could not be run in break mode.

I suspect that the main problem stems from the fact that the code you are using is desiged to be run from Excel. Perhaps it can be made to work but I think this will be an uphill battle.

I have modified my code to do essentially what your code seemed to do. You can always add stuff if you need it. I think it is pretty quick since it dumps the data in one hit although the column headings are treated separately. This code should not leave any unwanted instances of Excel running.

Steve


Private Sub ExportToExcel()
On Error GoTo ErrorHandler

    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object
    Dim strXLFile As String
    Dim strSheet As String
    Dim rst As ADODB.Recordset
    Dim iCols As Integer
   
    strXLFile = "C:\Test\Testwb.xls"
    strSheet = "Sheet1"  '<---Name of worksheet in file
    'Open a the workbook in Excel
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open(strXLFile)
    Set xlWs = xlWb.Worksheets(strSheet)
    Set rst = New ADODB.Recordset
    rst.Open "Table1", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
    For iCols = 0 To rst.Fields.Count - 1
        xlWs.Cells(1, iCols + 1).Value = rst.Fields(iCols).Name
    Next
    xlWs.Range(xlWs.Cells(1, 1), xlWs.Cells(1, rst.Fields.Count)).Font.Bold = True
    xlWs.Range("A2").CopyFromRecordset rst '<---begin putting data in cell A2
    rst.Close
   
    xlWs.Columns.AutoFit
    xlWb.Save
    xlApp.Quit
   
    Set rst = Nothing
    Set xlApp = Nothing
    Set xlWb = Nothing
    Set xlWs = Nothing
   
ExitRoutine:
    Exit Sub

ErrorHandler:
    If Not xlApp Is Nothing Then
        'make Excel visible if an error occurs
        xlApp.Visible = True
        Set xlApp = Nothing
    End If
    If Not xlWb Is Nothing Then
        Set xlWb = Nothing
    End If
    If Not xlWs Is Nothing Then
        Set xlWs = Nothing
    End If
    'Close rst
    If Not rst Is Nothing Then
        rst.Close
    End If
   
    MsgBox Err.Description & " Error Number: " & Err.Number
    Resume ExitRoutine

End Sub