|
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
|
|
|
|
|
