I have an application in Access 2003. It uses VBA to open an Excel file. The file has one tab for charts and one for data. The program counts how many charts needs to be created, one per project. It then will place 4 charts per tab, creating as many chart tabs as necessary, keep one data tab.
The program then writes the data and links the data to the corresponding chart. It will also write legends, and scale the charts. This all works fine under Access 2003/Excel 2003.
The error I get is
"Application-defined error or object defined error"
The line that gives me the error is:
Set chCopy = xlsheet.ChartObjects(idx)
I am using the Multi-Chart option frmChartType = 1
Now I'm moving to the Office 2010 world. It is not working. Below is the code I run to do the magic. I guess something is happening in Excel 2010 that is different from 2003.
PS - I found when I comment out the error line, and other lines dependent on chCopy it creates the charts, but all the charts are pictures and not charts!!
The program then writes the data and links the data to the corresponding chart. It will also write legends, and scale the charts. This all works fine under Access 2003/Excel 2003.
The error I get is
"Application-defined error or object defined error"
The line that gives me the error is:
Set chCopy = xlsheet.ChartObjects(idx)
I am using the Multi-Chart option frmChartType = 1
Now I'm moving to the Office 2010 world. It is not working. Below is the code I run to do the magic. I guess something is happening in Excel 2010 that is different from 2003.
PS - I found when I comment out the error line, and other lines dependent on chCopy it creates the charts, but all the charts are pictures and not charts!!
Code:
Public Sub GenerateChart()
' Generate an Excel chart
Dim db As Database
Dim rst As DAO.Recordset
Dim xlapp As Object
Dim xlBook As Object
Dim xlChart As Object
Dim xlData As Object
Dim xlsheet As Object
Dim ch As Object
Dim chCopy As Object
Dim idx As Integer
Dim row As Integer
Dim i As Integer
Dim fs As Variant
Dim noOfProjects As Integer
Dim rejectionReasonList As Variant
Dim CPN As String
Dim dataRow As Integer
Dim base As Integer
Dim maxPercent As Single ' Keep track of max percent for scaling
Dim chartNo As Integer
Dim wsNo As Integer ' Worksheet number
Dim ExcelDefault As String ' Default name for Excel output file
Dim rstEmpty As Boolean
Dim docCnt As Integer
On Error GoTo Errors
rstEmpty = False
' Initialize array
rejectionReasonList = Array("CAD", "CHECK-IN/OUT", "DRAWING CONTENT", "INDEX INFO")
' Verify that the user has entered at least 1 project
noOfProjects = DCount("ProjectID", "qryRptProject")
If noOfProjects = 0 Then
MsgBox "You must enter at least one project", vbInformation, "No project entered"
Exit Sub ' Check if no project was found, then exit
End If
Set fs = CreateObject("Scripting.FileSystemObject")
If frmChartType = 1 Then ' Multi Chart
' Verify that the template file exists
If Not fs.FileExists(CurrentProject.path & "\RejectionReasonMultiChartTemplate.xls") Then
MsgBox "The template file does not exist." & vbCrLf & _
"A file called 'RejectionReasonMultiChartTemplate.xls' is required in the database directory", vbExclamation, _
"Missing template file"
Set fs = Nothing
Exit Sub
End If
Else ' Single Chart
' Verify that the template file exists
If Not fs.FileExists(CurrentProject.path & "\RejectionReasonSingleChartTemplate.xls") Then
MsgBox "The template file does not exist." & vbCrLf & _
"A file called 'RejectionReasonSingleChartTemplate.xls' is required in the database directory", vbExclamation, _
"Missing template file"
Set fs = Nothing
Exit Sub
End If
End If
' check if the output folder exists
If Not fs.FolderExists(getPath(txtExcelName)) And getPath(txtExcelName) <> "" Then
MsgBox "The output directory, " & getPath(txtExcelName) & ", does not exists.", _
vbExclamation, "Output directory does not exists"
Set fs = Nothing
Exit Sub
End If
' check if the file exists
If fs.FileExists(txtExcelName) Then
If MsgBox("File already exists. Overwrite?", vbYesNo, "File already exists") <> vbYes Then
Set fs = Nothing
Exit Sub
End If
End If
' Turn on hourglass. This may take awhile
DoCmd.Hourglass True
' Create Excel Application
Set xlapp = CreateObject("Excel.Application")
If Err Or (xlapp Is Nothing) Then
DoCmd.Hourglass False
MsgBox "Could not create Excel Application. See System Administrator", vbCritical, "Excel Start up Error"
Set fs = Nothing
Exit Sub
End If
' Copy template file to the new location
If frmChartType = 1 Then 'Multi chart
fs.copyfile CurrentProject.path & "\RejectionReasonMultiChartTemplate.xls", txtExcelName 'Default is overwrite
Else ' Single Chart
fs.copyfile CurrentProject.path & "\RejectionReasonSingleChartTemplate.xls", txtExcelName 'Default is overwrite
End If
' Open the spreadsheet and set up the Excel objects
Set xlBook = xlapp.Workbooks.Open(txtExcelName)
Set xlData = xlBook.Worksheets("Data") 'Need this for Cells method
If frmChartType = 1 Then ' Multiple chart
Set xlChart = xlBook.Worksheets("Chart 1") 'Need this for Cells method
Else
Set xlChart = xlBook.Worksheets("Chart") 'Need this for Cells method
End If
' Find the number of unique projects in the table
noOfProjects = DCount("CPN", "qryCARPrj")
' Add the number of necessary worksheets to the multiple projects spreadsheet
If frmChartType = 1 Then
For i = 2 To Int((noOfProjects - 1) / 4) + 1
idx = 0 'The chart number within the worksheet
Set xlsheet = xlBook.Worksheets.Add(xlData) 'Add new tab before the data tab
' Put in the header and footer information
xlsheet.PageSetup.CenterHeader = "&18DSS Corrective Action Required Reasons by Project and Corrective Action Required Type"
xlsheet.PageSetup.LeftFooter = "&D"
xlsheet.PageSetup.CenterFooter = "Page &P of &N"
xlsheet.Name = "Chart " & i
xlChart.Activate
For Each ch In xlChart.ChartObjects
ch.Copy
xlsheet.Range(ch.TopLeftCell.Address).PasteSpecial (xlPasteAll)
idx = idx + 1
' NEXT LINE GENERATES THE ERROR
Set chCopy = xlsheet.ChartObjects(idx)
dataRow = 4 * 4 * (i - 1) + (idx - 1) * 4 + 2
chCopy.Chart.SeriesCollection(1).XValues = xlData.Range("B" & dataRow & ":B" & dataRow + 3)
chCopy.Chart.SeriesCollection(1).Values = xlData.Range("C" & dataRow & ":C" & dataRow + 3)
chCopy.Chart.SeriesCollection(2).Values = xlData.Range("D" & dataRow & ":D" & dataRow + 3)
Next
Next i
End If
' Open the recordset
Set db = CurrentDb()
If frmChartType = 1 Then ' Multi Chart
' Set rst = db.OpenRecordset("qryRejectionReasonMulti")
Set rst = db.OpenRecordset("qryCARMulti")
Else ' Single Chart
' Set rst = db.OpenRecordset("qryRejectionReasonSingle")
Set rst = db.OpenRecordset("qryCARSingle")
End If
If rst.EOF And rst.BOF Then
MsgBox ("No records found for selected project(s). Canceling request...")
rstEmpty = True
GoTo CloseAll
End If
' Turn off events in the spreadsheet so that changed cells are not highlighted
xlapp.EnableEvents = False
' Populate the worksheet(s)
row = 2
maxPercent = 0
If frmChartType = 1 Then ' Mutliple charts
Do Until rst.EOF
' Add five new rows for each project
For i = 0 To 3
xlData.Cells(row + i, 1) = rst!CPN
xlData.Cells(row + i, 2) = rejectionReasonList(i)
xlData.Cells(row + i, 3) = 0 ' Rejection Percentage. Default to zero
xlData.Cells(row + i, 4) = 0 ' Repear Rejection. Default to zero
xlData.Cells(row + i, 5).Formula = "=C" & row + i & "+D" & row + i ' Total Rejections. Formula.
xlData.Cells(row + i, 6) = 0 ' Count of CARs. Default to zero
xlData.Cells(row + i, 7) = 0 ' Count of Documents. Default to zero
' xlData.Cells(row + i, 6) = Int(row / 4) + 1 ' Chart number
Next i
' Write the percentage and counts found
CPN = rst!CPN
maxPercent = 0
docCnt = 0
Do Until rst.EOF
If CPN <> rst!CPN Then Exit Do
Select Case rst!Reason
Case "CAD"
xlData.Cells(row, 3) = Round(rst!DocPercent, 2)
xlData.Cells(row, 4) = Round(rst!TotalPercent - rst!DocPercent, 2)
xlData.Cells(row, 6) = rst!CountOfCAR
Case "CHECK-IN/OUT"
xlData.Cells(row + 1, 3) = Round(rst!DocPercent, 2)
xlData.Cells(row + 1, 4) = Round(rst!TotalPercent - rst!DocPercent, 2)
xlData.Cells(row + 1, 6) = rst!CountOfCAR
Case "DRAWING CONTENT"
xlData.Cells(row + 2, 3) = Round(rst!DocPercent, 2)
xlData.Cells(row + 2, 4) = Round(rst!TotalPercent - rst!DocPercent, 2)
xlData.Cells(row + 2, 6) = rst!CountOfCAR
Case "INDEX INFO"
xlData.Cells(row + 3, 3) = Round(rst!DocPercent, 2)
xlData.Cells(row + 3, 4) = Round(rst!TotalPercent - rst!DocPercent, 2)
xlData.Cells(row + 3, 6) = rst!CountOfCAR
End Select
If rst!CountOfDocs > docCnt Then docCnt = rst!CountOfDocs
If rst!TotalPercent > maxPercent Then maxPercent = rst!TotalPercent
rst.MoveNext
Loop
xlData.Cells(row, 7) = docCnt
xlData.Cells(row + 1, 7) = docCnt
xlData.Cells(row + 2, 7) = docCnt
xlData.Cells(row + 3, 7) = docCnt
' Default chart is a max of 40%. If maxpercent is > 35 then rescale the chart by adding 5% to the max.
If maxPercent > 40 Then
wsNo = Int((row - 2) / 16) + 1
Set xlChart = xlBook.Worksheets("Chart " & wsNo)
chartNo = Int((row - 2 - ((wsNo - 1) * 16)) / 4) + 1
maxPercent = (Fix((maxPercent + 0.01) * 100 / 10) + 1) / 10 ' Determine MaximumScale value.
' maxPercent = maxPercent + 0.05 ' Add 5% above max value so max category is displayed.
xlChart.ChartObjects(chartNo).Chart.Axes(xlValue).MaximumScale = maxPercent
End If
row = row + 4 ' Next project
Loop
' Put in chart titles (CPN)for the worksheet(s)
For i = 1 To Int((noOfProjects - 1) / 4) + 1
Set xlChart = xlBook.Worksheets("Chart " & i)
base = (i - 1) * 16
If xlData.Cells(base + 2, 1) <> "" Then xlChart.ChartObjects(1).Chart.ChartTitle.text = xlData.Cells(base + 2, 1)
If xlData.Cells(base + 7, 1) <> "" Then xlChart.ChartObjects(2).Chart.ChartTitle.text = xlData.Cells(base + 7, 1)
If xlData.Cells(base + 12, 1) <> "" Then xlChart.ChartObjects(3).Chart.ChartTitle.text = xlData.Cells(base + 12, 1)
If xlData.Cells(base + 17, 1) <> "" Then xlChart.ChartObjects(4).Chart.ChartTitle.text = xlData.Cells(base + 17, 1)
Next i
Else ' Single chart
Do Until rst.EOF
xlData.Cells(row, 1) = rst!CPN
xlData.Cells(row, 2) = Round(Nz(rst!DocPercent, 0))
xlData.Cells(row, 4) = Round(Nz(rst!TotalPercent, 0))
xlData.Cells(row, 3).Formula = "=D" & row & "-B" & row
xlData.Cells(row, 5) = rst!CountOfCAR
xlData.Cells(row, 6) = rst!CountOfDocs
If rst!TotalPercent > maxPercent Then maxPercent = rst!TotalPercent
row = row + 1
rst.MoveNext
Loop
' Make chart tab active
xlChart.Activate
maxPercent = (Fix((maxPercent + 0.01) * 100 / 10) + 1) / 10 ' Determine MaximumScale value.
xlChart.ChartObjects(1).Chart.Axes(xlValue).MaximumScale = maxPercent
' Update X and Y values
dataRow = noOfProjects + 1
xlChart.ChartObjects(1).Chart.SeriesCollection(1).XValues = xlData.Range("A2" & ":A" & dataRow)
xlChart.ChartObjects(1).Chart.SeriesCollection(1).Values = xlData.Range("B2" & ":B" & dataRow)
xlChart.ChartObjects(1).Chart.SeriesCollection(2).Values = xlData.Range("C2" & ":C" & dataRow)
' Resize chart width based on the number of projects
If noOfProjects > 2 Then xlChart.ChartObjects(1).Width = 100 + noOfProjects * 40
End If
rst.Close
Set rst = Nothing
CloseAll:
'Close objects
If Not xlData Is Nothing Then
Set xlData = Nothing
End If
If Not xlChart Is Nothing Then
Set xlChart = Nothing
End If
If Not xlsheet Is Nothing Then
Set xlsheet = Nothing
End If
If Not xlBook Is Nothing Then
xlBook.Save
xlBook.Close False
Set xlBook = Nothing
End If
' Close Excel
If Not xlapp Is Nothing Then
xlapp.Quit
Set xlapp = Nothing
DoEvents
End If
' Open Excel back up, with the file, so the user may view
If Not rstEmpty Then Call Shell("Excel """ & txtExcelName & """", vbMaximizedFocus)
DoCmd.Hourglass False
Exit Sub
Errors: ' Can get an error if Excel SaveAs cancelled
If Err = 1004 Then
xlBook.Close False 'SaveAs Cancelled
Else
MsgBox "Error in GenerateChart, Error " & Err & ": " & Err.Description, vbCritical, "Unexpected error"
End If
If Not xlapp Is Nothing Then
xlapp.Quit
Set xlapp = Nothing
DoEvents
End If
' Turn off hourglass
DoCmd.Hourglass False
' Close form and report
DoEvents
End Sub
Last edited: