headings not transferred to excel

[chimp]

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

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

 

[Norie]

I don't think this is the whole code.

Where is the ExcelDataTransfer procedure?

 

[chimp]

i aint to good at this code thing but is this what you are after?

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

 

[Norie]

Why not just use DoCmd.TransferSpreadsheet?

 

[chimp]

i dont know to be honest, this is a system i have inherited, it is so messed up, i am just trying to get this to work before i try to sort this one out....

an example of how badly it is set up is the tables are not normalised in any shape or form.


but i just wanna sort this out, then i will look at the transfer spreadhaeet option

 

[Norie]

What i'm thinking is that you should start from scratch.

The DoCmd.TransferSpreadSheet will, in one line, export a query/table to Excel, with field names.

 

[chimp]

out of curiosity, could i use the transfer spreadsheet thing to output to a template ?

example:

i have a table...

table name: OEETrendGraph

strName ----- >OEE Trend Graph
strFilter ----- >FactoryModel_OEETrendGrpCT
strTemplate --- >\\TECH02\OeeData\GraphTemplates\OEETrend.xlt

as it is currntly on the click of a preview button the data from my query is output to the template .

how would i write the transfer spreadsheet thing to carry this out ?

 

[Norie]

The general syntax for it is:

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, "TableOrQueryName", "File.xls"

I don't know how it would work with a template.

Also I'm using Excel97 so the second parameter may be different for you.

 

[mdmilner]

Noticed the comments indicated 1998 was the development time frame.
This is a good source of information for how to transfer data to excel

http://www.mvps.org/access/modules/mdl0035.htm

The code sample you provided doesn't use any of them, precisely.
Below is a segment from your 2nd code post. This is where it is copying values from the recordset to the fields in the excel spreadsheet.

If you'd really like to modify this, what you need to do is throw in your header column values in a quick loop outside and before all of the cell values being written. You also need to ensure that you don't write the values then rewrite them below.

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

Code for this would look like:
Notice the only addition is the .Name in the second row below.

For i = intStartCol To (intStartCol + rs.Fields.Count - 1) 
.Cells(intRow, i).Value = rs.Fields(i - intStartCol).Name
Next i

Your code might end up looking like:

With xlsSheet 
  intRow = intStartRow 

  For i = intStartCol To (intStartCol + rs.Fields.Count - 1) 
    .Cells(intRow, i).Value = rs.Fields(i - intStartCol).Name
  Next i 
  intRow = intRow + 1 

  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

Main advantage of this kind of method is absolute control over placement of data. Also, it is always possible/likely/required that the output table/query isn't normalised because it needs to be the way it is to format the output. You can also build in routines that format the sheet.

Mike