In Access ADP project, I am trying to copy an Excel Chart to a JPG file using the VBA code. This code runs for first time after opening the Access project but gives error if rerun. The error occurs at the following line in Sub CreateJPG.
ActiveChart.ChartArea.Select
The error number is o and description is blank.
Please help to locate the source of error. This code is yet not fully written /optimised and is in proof of conecpt stage.
Thanks
Ashok
'The following is the main routine.
Sub CopyExcelChartToJPGFile()
Dim YN As String
Dim MyExcel As New Excel.Application
Dim MyWorkBook As Workbook
Dim MySheet1 As Worksheet
Dim I, J, OKCan, ChartsCount As Integer
Dim SheetName, FileName, JPGFileName, JPGFileFolderPathName, SQLStr, MsgText, ActiveChartName As String
On Error GoTo Err1
OKCan = MsgBox("You are about to create jpg files of the charts on the worksheet: " & SheetName & Chr(10) & Chr(10) & "Please confirm ?", vbOKCancel)
If OKCan = vbCancel Then
If MyExcel Is Nothing Then
Else
Set MyExcel = Nothing
End If
MsgBox "You have cancelled the creation of jpg files."
Exit Sub
End If
JPGFileFolderPathName = "D:\Dashboard\Test\"
FileName = "D:\Dashboard\Dashboardsv141.7.xls"
SheetName = "Finance"
CellRange = "B3" & ":" & "D4"
MyExcel.Workbooks.Open FileName
I = MyExcel.Workbooks.Count
Set MyWorkBook = MyExcel.Workbooks(1)
MySheetNo = GetSheetNoFromName(MyWorkBook, "TempWork")
Set MySheet1 = MyWorkBook.Sheets(MySheetNo)
MySheetNo = GetSheetNoFromName(MyWorkBook, SheetName)
If MySheetNo < 1 Then
MsgBox ("Sheet " & SheetName & " not found in the Workbook.")
MyWorkBook.Close
If MyExcel Is Nothing Then
Else
Set MyExcel = Nothing
End If
Exit Sub
End If
' MyExcel.Visible = True
MySheetNo = GetSheetNoFromName(MyWorkBook, SheetName)
If MySheetNo > 0 Then
JPGFileName = SheetName & "Chart01"
Call CreateJPG(MyWorkBook, MySheetNo, MySheet1, CellRange, JPGFileFolderPathName, JPGFileName)
End If
If MySheet1 Is Nothing Then
Else
Set MySheet1 = Nothing
End If
MyWorkBook.Close SaveChanges:=False
If MyExcel Is Nothing Then
Else
Set MyExcel = Nothing
End If
Exit Sub
Err1:
MsgBox "Error No: " & Err.Number & Chr(10) & Err.Description & Chr(10) & "Error Location: " & ErrorLocation & " in Sub PictureExport of Module CopyExcelChartsToJPGFiles."
If MySheet1 Is Nothing Then
Else
Set MySheet1 = Nothing
End If
MyWorkBook.Close SaveChanges:=False
If MyExcel Is Nothing Then
Else
Set MyExcel = Nothing
End If
End Sub
'Error occurs in this routine which is called in the main routine.
Sub CreateJPG(ByRef MyWorkBook As Workbook, ByVal MySheetNo As Integer, ByRef MySheet1 As Worksheet, CellRange, ByVal JPGFileFolderPathName As String, ByVal JPGFileName As String)
Dim TempChart, MsgText, Picture2Export As String
Dim PicWidth, PicHeight As Long
Dim MySheet As Worksheet
Dim MyChart As Chart
Dim I, ChartsCount As Integer
On Error GoTo Err1
If (MyWorkBook Is Nothing) Or (MySheetNo < 1) Or (MySheet1 Is Nothing) Or IsEmpty(JPGFileFolderPathName) Or IsEmpty(JPGFileName) Then
MsgBox "Invalid value of parameters passed to Sub CreateJPG." & Chr(10) & "JPG not created."
Exit Sub
End If
'Copy a Range as picture onto "TempWork" sheet
Set MySheet = MyWorkBook.Sheets(MySheetNo)
MySheet.Select
MySheet.Range(CellRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
MySheet1.Select
MySheet1.Range("A1").Select
MySheet1.Paste
Picture2Export = MySheet1.Shapes(1).Name
PicHeight = MySheet1.Shapes(1).Height
PicWidth = MySheet1.Shapes(1).Width
'Add a temporary chart in sheet1
ChartsCount = MyWorkBook.Charts.Count
MyWorkBook.Charts.Add
TempChart = MyWorkBook.Charts(1).Name
Set MyChart = MyWorkBook.Charts(1)
ChartsCount = MyWorkBook.Charts.Count
'Move the added chart to "TempWork" sheet
MyWorkBook.Charts(1).Location WHERE:=xlLocationAsObject, Name:="TempWork"
I = MySheet1.Shapes.Count
'Copy the picture to clipboard
MySheet1.Range("A30").Select
MySheet1.Shapes(1).Select
MySheet1.Shapes(1).Copy
'Patse the picture to chart area
MySheet1.ChartObjects(1).Activate
ActiveChart.ChartArea.Select 'This line gives error on rerun.
ActiveChart.Paste
'Export the picture to a file
ActiveChart.Export FileName:=JPGFileFolderPathName & JPGFileName & ".jpg", FilterName:="jpg"
'Cut Chart and Picture objects
ActiveChart.ChartArea.ClearContents
ChartsCount = MyWorkBook.Charts.Count
I = MySheet1.Shapes.Count
MySheet1.ChartObjects(1).Cut
For I = 1 To MySheet1.ChartObjects.Count
MySheet1.ChartObjects(I).Cut
Next I
For I = 1 To MySheet1.Shapes.Count
MySheet1.Shapes(I).Cut
Next I
If MyChart Is Nothing Then
Else
Set MyChart = Nothing
End If
If MySheet Is Nothing Then
Else
Set MySheet = Nothing
End If
Exit Sub
Err1:
On Error Resume Next
MsgBox "Error No: " & Err.Number & Chr(10) & Err.Description & Chr(10) & "Error Location: " & ErrorLocation & " in Sub CreateJPG of Module CopyExcelChartsToJPGFiles."
If MyChart Is Nothing Then
Else
Set MyChart = Nothing
End If
If MySheet Is Nothing Then
Else
Set MySheet = Nothing
End If
End Sub
Function GetSheetNoFromName(ByRef MyWorkBook As Workbook, ByVal MySheetName As String) As Integer
Dim I, J As Integer
Dim MySheet As Worksheet
I = MyWorkBook.Sheets.Count
J = 0
GetSheetNoFromName = 0
Do While J < I
J = J + 1
Set MySheet = MyWorkBook.Sheets(J)
If MySheet.Name = MySheetName Then
GetSheetNoFromName = J
J = I + 100
End If
Loop
End Function
ActiveChart.ChartArea.Select
The error number is o and description is blank.
Please help to locate the source of error. This code is yet not fully written /optimised and is in proof of conecpt stage.
Thanks
Ashok
'The following is the main routine.
Sub CopyExcelChartToJPGFile()
Dim YN As String
Dim MyExcel As New Excel.Application
Dim MyWorkBook As Workbook
Dim MySheet1 As Worksheet
Dim I, J, OKCan, ChartsCount As Integer
Dim SheetName, FileName, JPGFileName, JPGFileFolderPathName, SQLStr, MsgText, ActiveChartName As String
On Error GoTo Err1
OKCan = MsgBox("You are about to create jpg files of the charts on the worksheet: " & SheetName & Chr(10) & Chr(10) & "Please confirm ?", vbOKCancel)
If OKCan = vbCancel Then
If MyExcel Is Nothing Then
Else
Set MyExcel = Nothing
End If
MsgBox "You have cancelled the creation of jpg files."
Exit Sub
End If
JPGFileFolderPathName = "D:\Dashboard\Test\"
FileName = "D:\Dashboard\Dashboardsv141.7.xls"
SheetName = "Finance"
CellRange = "B3" & ":" & "D4"
MyExcel.Workbooks.Open FileName
I = MyExcel.Workbooks.Count
Set MyWorkBook = MyExcel.Workbooks(1)
MySheetNo = GetSheetNoFromName(MyWorkBook, "TempWork")
Set MySheet1 = MyWorkBook.Sheets(MySheetNo)
MySheetNo = GetSheetNoFromName(MyWorkBook, SheetName)
If MySheetNo < 1 Then
MsgBox ("Sheet " & SheetName & " not found in the Workbook.")
MyWorkBook.Close
If MyExcel Is Nothing Then
Else
Set MyExcel = Nothing
End If
Exit Sub
End If
' MyExcel.Visible = True
MySheetNo = GetSheetNoFromName(MyWorkBook, SheetName)
If MySheetNo > 0 Then
JPGFileName = SheetName & "Chart01"
Call CreateJPG(MyWorkBook, MySheetNo, MySheet1, CellRange, JPGFileFolderPathName, JPGFileName)
End If
If MySheet1 Is Nothing Then
Else
Set MySheet1 = Nothing
End If
MyWorkBook.Close SaveChanges:=False
If MyExcel Is Nothing Then
Else
Set MyExcel = Nothing
End If
Exit Sub
Err1:
MsgBox "Error No: " & Err.Number & Chr(10) & Err.Description & Chr(10) & "Error Location: " & ErrorLocation & " in Sub PictureExport of Module CopyExcelChartsToJPGFiles."
If MySheet1 Is Nothing Then
Else
Set MySheet1 = Nothing
End If
MyWorkBook.Close SaveChanges:=False
If MyExcel Is Nothing Then
Else
Set MyExcel = Nothing
End If
End Sub
'Error occurs in this routine which is called in the main routine.
Sub CreateJPG(ByRef MyWorkBook As Workbook, ByVal MySheetNo As Integer, ByRef MySheet1 As Worksheet, CellRange, ByVal JPGFileFolderPathName As String, ByVal JPGFileName As String)
Dim TempChart, MsgText, Picture2Export As String
Dim PicWidth, PicHeight As Long
Dim MySheet As Worksheet
Dim MyChart As Chart
Dim I, ChartsCount As Integer
On Error GoTo Err1
If (MyWorkBook Is Nothing) Or (MySheetNo < 1) Or (MySheet1 Is Nothing) Or IsEmpty(JPGFileFolderPathName) Or IsEmpty(JPGFileName) Then
MsgBox "Invalid value of parameters passed to Sub CreateJPG." & Chr(10) & "JPG not created."
Exit Sub
End If
'Copy a Range as picture onto "TempWork" sheet
Set MySheet = MyWorkBook.Sheets(MySheetNo)
MySheet.Select
MySheet.Range(CellRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
MySheet1.Select
MySheet1.Range("A1").Select
MySheet1.Paste
Picture2Export = MySheet1.Shapes(1).Name
PicHeight = MySheet1.Shapes(1).Height
PicWidth = MySheet1.Shapes(1).Width
'Add a temporary chart in sheet1
ChartsCount = MyWorkBook.Charts.Count
MyWorkBook.Charts.Add
TempChart = MyWorkBook.Charts(1).Name
Set MyChart = MyWorkBook.Charts(1)
ChartsCount = MyWorkBook.Charts.Count
'Move the added chart to "TempWork" sheet
MyWorkBook.Charts(1).Location WHERE:=xlLocationAsObject, Name:="TempWork"
I = MySheet1.Shapes.Count
'Copy the picture to clipboard
MySheet1.Range("A30").Select
MySheet1.Shapes(1).Select
MySheet1.Shapes(1).Copy
'Patse the picture to chart area
MySheet1.ChartObjects(1).Activate
ActiveChart.ChartArea.Select 'This line gives error on rerun.
ActiveChart.Paste
'Export the picture to a file
ActiveChart.Export FileName:=JPGFileFolderPathName & JPGFileName & ".jpg", FilterName:="jpg"
'Cut Chart and Picture objects
ActiveChart.ChartArea.ClearContents
ChartsCount = MyWorkBook.Charts.Count
I = MySheet1.Shapes.Count
MySheet1.ChartObjects(1).Cut
For I = 1 To MySheet1.ChartObjects.Count
MySheet1.ChartObjects(I).Cut
Next I
For I = 1 To MySheet1.Shapes.Count
MySheet1.Shapes(I).Cut
Next I
If MyChart Is Nothing Then
Else
Set MyChart = Nothing
End If
If MySheet Is Nothing Then
Else
Set MySheet = Nothing
End If
Exit Sub
Err1:
On Error Resume Next
MsgBox "Error No: " & Err.Number & Chr(10) & Err.Description & Chr(10) & "Error Location: " & ErrorLocation & " in Sub CreateJPG of Module CopyExcelChartsToJPGFiles."
If MyChart Is Nothing Then
Else
Set MyChart = Nothing
End If
If MySheet Is Nothing Then
Else
Set MySheet = Nothing
End If
End Sub
Function GetSheetNoFromName(ByRef MyWorkBook As Workbook, ByVal MySheetName As String) As Integer
Dim I, J As Integer
Dim MySheet As Worksheet
I = MyWorkBook.Sheets.Count
J = 0
GetSheetNoFromName = 0
Do While J < I
J = J + 1
Set MySheet = MyWorkBook.Sheets(J)
If MySheet.Name = MySheetName Then
GetSheetNoFromName = J
J = I + 100
End If
Loop
End Function
