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