Function CreateChart(strSourceName As String, strFileName As String)
Dim xlApp As Excel.Application
Dim xlWrkbk As Excel.Workbook
Dim xlChartObj As Excel.Chart
Dim xlSourceRange As Excel.Range
Dim xlColPoint As Excel.Point
On Error GoTo Err_CreateChart
' Create an Excel workbook file based on the
' object specified in the second argument.
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, strSourceName, strFileName, False
' Create a Microsoft Excel object.
Set xlApp = CreateObject("Excel.Application")
' Open the spreadsheet to which you exported the data.
Set xlWrkbk = xlApp.Workbooks.Open(strFileName)
' Determine the size of the range and store it.
Set xlSourceRange = xlWrkbk.Worksheets(1).Range("a1").CurrentRegion
' Create a new chart.
Set xlChartObj = xlApp.Charts.Add
' Format the chart.
With xlChartObj
' Specify chart type as 3D.
.ChartType = xl3DColumn
' Set the range of the chart.
.SetSourceData Source:=xlSourceRange, PlotBy:=xlColumns
' Specify that the chart is located on a new sheet.
.Location Where:=xlLocationAsNewSheet
' Create and set the title; set title font.
.HasTitle = True
'With .ChartTitle
.Characters.Text = "Total Sales by Country"
.Font.Size = 18
End With
' Rotate the x-axis labels to a 45-degree angle.
.Axes(xlCategory).TickLabels.Orientation = 45
' Delete the label at the far right of the x-axis.
.Axes(xlSeries).Delete
' Delete the legend.
.HasLegend = True
' Set each datapoint to show the dollar amount
' and format the datapoint to be currency
' with no decimals.
With .SeriesCollection(1)
.ApplyDataLabels Type:=xlDataLabelsShowValue
.DataLabels.NumberFormat = "$#,##0"
End With
End With
' Position the points further from the tops
' of the columns.
For Each xlColPoint In xlChartObj.SeriesCollection(1).Points
xlColPoint.DataLabel.Top = xlColPoint.DataLabel.Top - 11
Next xlColPoint
' Save and close the workbook
' and quit Microsoft Excel.
With xlWrkbk
.Save
.Close
End With
xlApp.Quit
Exit_CreateChart:
Set xlSourceRange = Nothing
Set xlColPoint = Nothing
Set xlChartObj = Nothing
Set xlWrkbk = Nothing
Set xlApp = Nothing
Exit Function
Err_CreateChart:
MsgBox CStr(Err) & " " & Err.Description
Resume Exit_CreateChart
End Function
Mostrar Mensajes
