Function Export2XLS(ByVal sQuery As String) Dim oExcel As Object Dim oExcelWrkBk As Object Dim oExcelWrSht As Object Dim bExcelOpened As Boolean Dim Db As DAO.Database Dim Rs As DAO.Recordset Dim iCols As Integer Const xlCenter = -4108 'Start Excel On Error Resume Next Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel If err.Number <> 0 Then 'Could not get instance of Excel, so create a new one err.Clear On Error GoTo Error_Handler Set oExcel = CreateObject("Excel.Application") bExcelOpened = False Else 'Excel was already running bExcelOpened = True End If On Error GoTo Error_Handler oExcel.ScreenUpdating = False oExcel.Visible = False 'Keep Excel hidden until we are done with our manipulation Set oExcelWrkBk = oExcel.Workbooks.Add() 'Start a new workbook Set oExcelWrSht = oExcelWrkBk.Sheets(1) 'Open our SQL Statement, Table, Query Set Db = CurrentDb Set Rs = Db.OpenRecordset(sQuery, dbOpenSnapshot) With Rs If .RecordCount <> 0 Then 'Build our Header For iCols = 0 To Rs.Fields.Count - 1 oExcelWrSht.cells(1, iCols + 1).Value = Rs.Fields(iCols).Name Next With oExcelWrSht.Range(oExcelWrSht.cells(1, 1), _ oExcelWrSht.cells(1, Rs.Fields.Count)) .Font.Bold = True .Font.ColorIndex = 2 .Interior.ColorIndex = 1 .HorizontalAlignment = xlCenter End With oExcelWrSht.Range(oExcelWrSht.cells(1, 1), _ oExcelWrSht.cells(1, Rs.Fields.Count)).columns.AutoFit 'Resize our Columns based on the headings 'Copy the data from our query into Excel oExcelWrSht.Range("A2").CopyFromRecordset Rs oExcelWrSht.Range("A1").Select 'Return to the top of the page Else MsgBox "Nema zapisa koji bi proizaĆĄao iz navedenog upita/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with" GoTo Error_Handler_Exit End If End With ' oExcelWrkBk.Close True, sFileName 'Save and close the generated workbook ' ' 'Close excel if is wasn't originally running ' If bExcelOpened = False Then ' oExcel.Quit ' End If Error_Handler_Exit: On Error Resume Next oExcel.Visible = True 'Make excel visible to the user Rs.Close Set Rs = Nothing Set Db = Nothing Set oExcelWrSht = Nothing Set oExcelWrkBk = Nothing oExcel.ScreenUpdating = True Set oExcel = Nothing Exit Function Error_Handler: MsgBox "The following error has occured" & vbCrLf & vbCrLf & _ "Error Number: " & err.Number & vbCrLf & _ "Error Source: Export2XLS" & vbCrLf & _ "Error Description: " & err.Description _ , vbOKOnly + vbCritical, "An Error has Occured!" Resume Error_Handler_Exit End Function