S
scadav
Hoping someone can help...
I use the following code (access database) with Access 2003 and Windows
XP and have no problems with Excel shutting down after the code runs. If
I use the same access database with the same version of Access on Vista,
Excel will stay running as a process. Anyone see anything like this
before?
=========================================================================
=========================================================================
Public Function ExcelExportStandard(sXLSTemplate As String, sVBAQuery As
String, oExcelProgress As Object, oExcelForm As Form, Optional sHeader1
As String, Optional sHeader2 As String)
On Error GoTo err_Handler
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Set appExcel = CreateObject("Excel.Application")
Dim sTemplate As String
Dim sOutput As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sSQL As String
Dim lRecords As Long
Dim iRow As Integer
Dim iCol As Integer
Dim iFld As Integer
Const cTab As Byte = 1
Const cStartRow As Byte = 6
Const cStartColumn As Byte = 1
Dim iSkipNewLineForNewGrouping As Integer
' Start with a clean file built from the template file
sTemplate = CurrentProject.Path & "\" & sXLSTemplate
sOutput = GetUserLocationAndFileName
If IsNull(sOutput) Or (sOutput = "") Then
MsgBox "No File Name Chosen, Exiting"
Exit Function
End If
If Dir(sTemplate) = "" Then
MsgBox "You are Missing a Required DLL (" & sTemplate & ") in
order to Output to Excel. Can't Complete Operation."
Exit Function
End If
FileCopy sTemplate, sOutput
' Create the Excel Applicaiton, Workbook and Worksheet and Database
object
'Set appExcel = Excel.Application
Set wbk = appExcel.Workbooks.Open(sOutput)
Set wks = appExcel.Worksheets(cTab)
' Create the recordset
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sVBAQuery, dbOpenSnapshot)
If Not rst.BOF Then rst.MoveFirst
' Set the starting point for the excel spreadsheet
' (these values are set to constants for easy future modifications)
iCol = cStartColumn
iRow = cStartRow
Do Until rst.EOF
'DoEvents
iFld = 0
lRecords = lRecords + 1
oExcelProgress.Visible = True
oExcelProgress.Value = "Exporting record #" & lRecords & " to " &
sOutput
oExcelForm.Repaint
For iCol = cStartColumn To cStartColumn + (rst.Fields.Count - 1)
wks.Cells(iRow, iCol) = rst.Fields(iFld)
If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
End If
wks.Cells(iRow, iCol).WrapText = False
iFld = iFld + 1
Next
wks.rows(iRow).EntireRow.AutoFit
iRow = iRow + 1
rst.MoveNext
Loop
' Save the export
wbk.Close savechanges:=True
appExcel.Application.Quit
Set wbk = Nothing: Set appExcel = Nothing
MsgBox "Complete"
exit_Here:
' Cleanup all objects (resume next on errors)
On Error Resume Next
Set wks = Nothing
Set wbk = Nothing
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
'DoCmd.Hourglass False
''''Me.lb_Status.Visible = False
Exit Function
err_Handler:
ExcelExport = Err.Description
MsgBox Err.Description
Resume exit_Here
End Function
=========================================================================
=========================================================================
Thanks in advance
I use the following code (access database) with Access 2003 and Windows
XP and have no problems with Excel shutting down after the code runs. If
I use the same access database with the same version of Access on Vista,
Excel will stay running as a process. Anyone see anything like this
before?
=========================================================================
=========================================================================
Public Function ExcelExportStandard(sXLSTemplate As String, sVBAQuery As
String, oExcelProgress As Object, oExcelForm As Form, Optional sHeader1
As String, Optional sHeader2 As String)
On Error GoTo err_Handler
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Set appExcel = CreateObject("Excel.Application")
Dim sTemplate As String
Dim sOutput As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sSQL As String
Dim lRecords As Long
Dim iRow As Integer
Dim iCol As Integer
Dim iFld As Integer
Const cTab As Byte = 1
Const cStartRow As Byte = 6
Const cStartColumn As Byte = 1
Dim iSkipNewLineForNewGrouping As Integer
' Start with a clean file built from the template file
sTemplate = CurrentProject.Path & "\" & sXLSTemplate
sOutput = GetUserLocationAndFileName
If IsNull(sOutput) Or (sOutput = "") Then
MsgBox "No File Name Chosen, Exiting"
Exit Function
End If
If Dir(sTemplate) = "" Then
MsgBox "You are Missing a Required DLL (" & sTemplate & ") in
order to Output to Excel. Can't Complete Operation."
Exit Function
End If
FileCopy sTemplate, sOutput
' Create the Excel Applicaiton, Workbook and Worksheet and Database
object
'Set appExcel = Excel.Application
Set wbk = appExcel.Workbooks.Open(sOutput)
Set wks = appExcel.Worksheets(cTab)
' Create the recordset
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sVBAQuery, dbOpenSnapshot)
If Not rst.BOF Then rst.MoveFirst
' Set the starting point for the excel spreadsheet
' (these values are set to constants for easy future modifications)
iCol = cStartColumn
iRow = cStartRow
Do Until rst.EOF
'DoEvents
iFld = 0
lRecords = lRecords + 1
oExcelProgress.Visible = True
oExcelProgress.Value = "Exporting record #" & lRecords & " to " &
sOutput
oExcelForm.Repaint
For iCol = cStartColumn To cStartColumn + (rst.Fields.Count - 1)
wks.Cells(iRow, iCol) = rst.Fields(iFld)
If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
End If
wks.Cells(iRow, iCol).WrapText = False
iFld = iFld + 1
Next
wks.rows(iRow).EntireRow.AutoFit
iRow = iRow + 1
rst.MoveNext
Loop
' Save the export
wbk.Close savechanges:=True
appExcel.Application.Quit
Set wbk = Nothing: Set appExcel = Nothing
MsgBox "Complete"
exit_Here:
' Cleanup all objects (resume next on errors)
On Error Resume Next
Set wks = Nothing
Set wbk = Nothing
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
'DoCmd.Hourglass False
''''Me.lb_Status.Visible = False
Exit Function
err_Handler:
ExcelExport = Err.Description
MsgBox Err.Description
Resume exit_Here
End Function
=========================================================================
=========================================================================
Thanks in advance