Exporting to Excel from Access

chimp · July 9th, 2004, 07:14 AM

this is my 1st post so hi....

i am using some code to export my query to excel to then create a fancy chart, this was a system setup by someone else who has now left the company.

the code is below, everything works fine except, i dont get the field headings transfered across, can someone please inform me where and how i should modify my code to take the headings across aswell please.

cheers

Andy

Quote:

quote:
Option Compare Database
Option Explicit

Dim objExcel As Excel.Application 'This will give an error if no reference set to Excel object

Const DATE_RANGE = 2 'optRange= 2 for entering in a Date Range

'constant for columns of list boxes that have data
' Const MATERIAL_FILTER = 1

Const GRAPH_QUERY = 1
Const GRAPH_TEMPLATE = 2

Private Sub cmdClose_Click()
On Error GoTo Err_cmdClose_Click

    DoCmd.Close
DoCmd.OpenForm "frmGraphsMenu", acNormal, "", "", , acNormal
Exit_cmdClose_Click:
    Exit Sub

Err_cmdClose_Click:
    MsgBox Err.Description
    Resume Exit_cmdClose_Click

End Sub

Private Sub cmdPreviewOEE_Click()
    GraphMake False
End Sub

Private Sub cmdPrint_Click()
    GraphMake True
End Sub

Private Sub optRange_AfterUpdate()
    If optRange = DATE_RANGE Then
        txtYearStartOEE.Enabled = True
        txtYearEndOEE.Enabled = True
    Else
        txtYearStartOEE.Enabled = False
        txtYearEndOEE.Enabled = False
    End If
    YearPeriodSet
End Sub

Sub YearPeriodSet()
    Dim dbs As Database
    Dim PeriodTable As Recordset
    Set dbs = DBEngine.Workspaces(0).Databases(0)
' Set PeriodTable = dbs.OpenRecordset("tblSystemDataCurrentPeriod")
'Purpose: Fill start and end year/periods in txt boxes when we want to see all periods
'Called From: optRange_AfterUpdate
    txtYearStartOEE = 2000
    txtYearEndOEE = 3000
End Sub

Private Function RequiredFieldsOK() As Boolean
On Error GoTo RequiredFieldsOK_Error

    'Ensure that all required fields have data in them
' If IsNull(lstMaterial.Column(MATERIAL_FILTER)) Then
' MsgBox "Please choose a Material type"
' GoTo RequiredFieldsOK_Exit
' End If

    If IsNull(lstGraphs) Then
        MsgBox "Please choose a graph"
        GoTo RequiredFieldsOK_Exit
    End If

    RequiredFieldsOK = True

RequiredFieldsOK_Exit:
    Exit Function

RequiredFieldsOK_Error:
    MsgBox "Error number " & Err.Number & ": " & Err.Description, vbOKOnly + vbInformation, "RequiredFieldsOK"
    Resume RequiredFieldsOK_Exit

End Function

Sub GraphMake(flgPrint As Boolean)

    Dim rs As Recordset
    Dim qdf As QueryDef
    Dim strTemplate As String
    Dim strQuery As String

On Error GoTo GraphMake_Error

    If RequiredFieldsOK() Then

        'Create recordset and get values to pass to ExcelDataTransfer
        strQuery = lstGraphs.Column(GRAPH_QUERY)
        strTemplate = lstGraphs.Column(GRAPH_TEMPLATE)

        Set qdf = CurrentDb.QueryDefs(strQuery)
        Set rs = qdf.OpenRecordset(dbOpenSnapshot)

        If ExcelDataTransfer(rs, 2, 1, objExcel, strTemplate, "Data") Then

            'Change Title of Graph
On Error GoTo GraphMake_Exit
    'Error will occur if there is no graph sheet
            objExcel.Sheets("Chart").Select
On Error GoTo GraphMake_Error
            With objExcel.ActiveChart
                .HasTitle = True
                .ChartTitle.Characters.Text = "OEE Trend for line H6 " '& [CmbGraphYearSelectOEE]
            End With

            If flgPrint Then
                objExcel.ActiveChart.PrintOut
            End If

            Set objExcel = Nothing
        End If
    End If

GraphMake_Exit:
    Exit Sub

GraphMake_Error:
    MsgBox "Error number " & Err.Number & ": " & Err.Description, vbOKOnly + vbInformation, "GraphMake"
    Resume GraphMake_Exit

End Sub
Private Sub OpenCalOEE_Click()
On Error GoTo Err_OpenCal_Click

    Dim stDocName As String
    Dim stLinkCriteria As String

    CalStartRef = "OEEgraphs"
    'DoCmd.Minimize

    stDocName = "frmCalender"
    DoCmd.OpenForm stDocName, , , stLinkCriteria

Exit_OpenCal_Click:
    Exit Sub

Err_OpenCal_Click:
    MsgBox Err.Description
    Resume Exit_OpenCal_Click

End Sub

also i have a modul that i believe is used

Quote:

quote:
Option Compare Database
Option Explicit

Dim xls As Excel.Application 'This will give an error if no reference set to Excel object

Public Function ExcelDataTransfer(rs As Recordset, intStartRow As Integer, intStartCol As Integer, objExcel As Object, Optional strTemplate, Optional strDataPage) As Boolean
'================================================= ===========================
'Maintenance Definition
'Version Date Coder Action
' 1 10-July-98 SY Singh Initial Keyin
'
'Calls:
' ExcelOpen
'
'Is Called By:
' GraphMake
'
'Purpose:
' Opens Excel and copies data to it
'
'Paramters:
' rs: A recordset containing the data that needs to be transferred
' intStartRow: Starting row in Excel worksheet where data is to be written
' intStartCol: Starting column in Excel worksheet where data is to be written
' strTemplate: (Optional) name of template to base new excel workbook on
' strDataPage: (Optional) name of page in new excel workbook where data will be written
'
'Notes:
'================================================= ===========================
On Error GoTo ExcelDataTransfer_Error

    Dim intRow As Integer
    Dim strQuery As String
    Dim varSysCmd As Variant
    Dim lngRecCount As Long
    Dim xlsSheet As Excel.Worksheet
    Dim i As Integer

    DoCmd.Hourglass True
    varSysCmd = SysCmd(acSysCmdSetStatus, "Checking Recordset")

    If rs.RecordCount = 0 Then
        Call MsgBox(prompt:="There is no data to graph for your chosen critera." & vbCrLf & "" & vbCrLf & "Please change criteria and try again.", _
         Buttons:=vbInformation + vbOKOnly + vbDefaultButton1, _
         Title:="No Data To Graph!")
    Else
        If ExcelOpen() Then

            'Initialise Progress bar
            rs.MoveLast
            lngRecCount = rs.RecordCount
            rs.MoveFirst
            varSysCmd = SysCmd(acSysCmdInitMeter, "Copying data to Excel", lngRecCount)

            'Open new workbook to which we will write data
            ' Use template if name has been passed in
            If Not IsMissing(strTemplate) Then
                xls.Workbooks.Add strTemplate
            Else
                xls.Workbooks.Add
            End If

            'Set object for the sheet to which we will write data
            ' If no sheet name provided then use current sheet
            If Not IsMissing(strDataPage) Then
                Set xlsSheet = xls.Worksheets(strDataPage)
            Else
                Set xlsSheet = xls.ActiveSheet
            End If

            With xlsSheet
                intRow = intStartRow
                Do Until rs.EOF
                    varSysCmd = SysCmd(acSysCmdUpdateMeter, intRow - intStartRow)
                    For i = intStartCol To (intStartCol + rs.Fields.Count - 1)
                        .Cells(intRow, i).Value = rs.Fields(i - intStartCol)
                    Next i
                    rs.MoveNext
                    intRow = intRow + 1
                Loop
            End With

            varSysCmd = SysCmd(acSysCmdRemoveMeter)

            xlsSheet.Visible = True
            xls.Visible = True
            Set objExcel = xls
            ExcelDataTransfer = True
        End If
    End If

ExcelDataTransfer_Exit:
    varSysCmd = SysCmd(acSysCmdRemoveMeter)
    varSysCmd = SysCmd(acSysCmdClearStatus)
    DoCmd.Hourglass False
    Exit Function

ExcelDataTransfer_Error:

    MsgBox "Error number " & Err.Number & ": " & Err.Description, vbOKOnly + vbInformation, "ExcelDataTransfer"
    Resume ExcelDataTransfer_Exit

End Function

Function ExcelOpen()
'================================================= ===========================
'Maintenance Definition
'Version Date Coder Action
' 1 10-July-98 SY Singh Initial Keyin
'
'Calls:
'
'Is Called By:
' ExcelDataTransfer
'
'Purpose:
' sets form level variable xls to either the
' currently open version of Excel or
' if necessary opens Excel
'
'Paramters:
'
'Notes:
'================================================= ===========================
    Dim flgRunning As Boolean
    Dim varSysCmd As Variant

On Error Resume Next
    'DoCmd.Hourglass True
    flgRunning = True

    varSysCmd = SysCmd(acSysCmdSetStatus, "Opening Excel")

    Set xls = GetObject(, "Excel.Application")
    If xls Is Nothing Then
        Set xls = New Excel.Application
        flgRunning = False
    End If

    If xls Is Nothing Then
        MsgBox "Can't Create Excel Object"
        ExcelOpen = False
    Else
        'If Not xls.Visible Then
        ' xls.Visible = True
        'End If
        ExcelOpen = True
    End If

    DoEvents

    varSysCmd = SysCmd(acSysCmdClearStatus)
    'DoCmd.Hourglass False
End Function

Bob Bedell · July 9th, 2004, 11:54 AM

Hi Andy,

In the module behind your form, you are declaring the following constant:

Const GRAPH_TEMPLATE = 2

The 2 represents the 3rd column (zero-based) in a table or query that is being used as the rowsource property for an unbound listbox on your form named "lstGraph". The list box is probably displaying the name of a template file (.xlt), but the 3rd column of the rowsource should hold the complete path to the template file ("C:\yourtemplate.xlt").

When your code reaches this point in you GraphMake subprocedure:

'Create recordset and get values to pass to ExcelDataTransfer
strQuery = lstGraphs.Column(GRAPH_QUERY)
strTemplate = lstGraphs.Column(GRAPH_TEMPLATE)

the path to your template file should be stored in strTemplate.

The template file is where your field headings will come from. Be sure the template file is set up correctly. It should contain a single row listing the column names of the fields you a trying to plot.

So when your code reaches your ExcelDataTransfer function, the loop:

With xlsSheet
   intRow = intStartRow
   Do Until rs.EOF
      varSysCmd = SysCmd(acSysCmdUpdateMeter, intRow - intStartRow)
      For i = intStartCol To (intStartCol + rs.Fields.Count - 1)
         .Cells(intRow, i).Value = rs.Fields(i - intStartCol)
      Next i
      rs.MoveNext
      intRow = intRow + 1
   Loop
End With

will load your worksheet with data, with the column headings already established by the template.

HTH,

Bob