I need a Christmas miracle - Saving Excel tables as pictures in a folder - Application-defined or object-defined error

chino3589

New Member
Joined
Oct 14, 2013
Messages
9
Hi,
I use VBA macros to take my data from an Excel spreadsheet and populate a Word document through a mailmerge. The goal of the main macro is to save multiple Excel tables in a jpg format into a specific folder.

The main macro do the following tasks:

  1. Take various Excel table (with named range TABLE1, TABLE2 etc.) from multiple Excel sheets in the same Excel file and establish if the table is needed
  2. Copy the Excel table and paste it as a picture over the Excel cells
  3. Create a temporary chart and use the picture from step 2 to populate the chart
  4. Export the Chart as a .jpg in the desired folder with the desired picture name
  5. Delete the temporary chart and picture from step 2 & 3
  6. Repeat for all tables
The macro usually works fine and is part of a final macro that combined other macros for the final mail merge.

THE PROBLEM

On line Sh.CopyPicture, I keep getting the error message Run-time error ‘1004’ Application-defined or object-defined error.

Everything works as expected in the macro until lines tmpChart.ChartArea.Width = Sh.Width and tmpChart.ChartArea.Height = Sh.Height do not return the expected results (the dimensions of the chart should be the same as of the picture, but in the macro they are way smaller).

I will answer all questions if you need more info.

Thank you and have a great Christmas time :)


VBA Code:
Sub SelectedRangeToImage()
Dim tmpChart As Chart, n As Long, shCount As Long, sht As Worksheet, Sh As Shape, rng As Range
Dim fileSaveName As Variant, pic As Variant
Dim strFolders As String
Dim i As Integer

strFolders = Application.ThisWorkbook.Path
strFolders = strFolders & "\" & "TablesPictures"
Shell ("cmd /c md " & Chr(34) & strFolders & Chr(34))

i = 1
Do Until i > 4    'Below are conditions to run only relevant tables


If (i = 1 And Range("Show_Table1").Value = "No") Or (i = 2 And Range("Show_Table2").Value = "No") _
Or (i = 3 And Range("Show_Table3").Value = "No") Or (i = 4 And Range("Show_Table4").Value = "No") Then
i = i + 1
   
Else

Application.Goto Reference:="TABLE" & i

ActiveWindow.Zoom = 300                        'Very important to zoom, otherwise the pictures are blurry

'Create temporary chart as canvas
Set sht = ActiveSheet
Set rng = sht.Range("Table" & i)
    rng.CopyPicture

With sht.Pictures.Paste
End With

Set Sh = sht.Shapes(sht.Shapes.Count)
Set tmpChart = Charts.Add
tmpChart.ChartArea.Clear
tmpChart.Name = "PicChart" & (Rnd() * 10000)
Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=sht.Name)
tmpChart.ChartArea.Width = Sh.Width
tmpChart.ChartArea.Height = Sh.Height
tmpChart.Parent.Border.LineStyle = 0

'Paste range as image to chart
    
Sh.CopyPicture    'HERE IS THE ERROR MESSAGE

With tmpChart.Pictures.Paste
End With

tmpChart.Export Filename:=strFolders & "\" & "Table" & i & ".jpg", Filtername:="JPG"
       
'Clean up
sht.Cells(1, 1).Activate
sht.ChartObjects(sht.ChartObjects.Count).Delete
Sh.Delete

ActiveWindow.Zoom = 115

i = i + 1
End If

Loop
End Sub
 

Some videos you may like

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,723
This might get U started. HTH. Dave
Code:
Set sht = ActiveSheet
Set rng = sht.Range("Table1")
    rng.CopyPicture
Charts.Add.Location Where:=xlLocationAsObject, Name:=sht.Name
Set CurrentChart = Sheets(sht.Name).ChartObjects(1).Chart
CurrentChart.Parent.Width = rng.Width
CurrentChart.Parent.Height = rng.Height
CurrentChart.Pictures.Paste
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,723
I guess I should have mentioned also that U can paste the XL table to a Word document without the chart image thing...
Code:
Set oApp = CreateObject("Word.Application")
'create doc
Set oDoc = oApp.Documents.Add
'Copy Table Range from Excel
      Set tbl = ThisWorkbook.Worksheets(1).ListObjects(1).Range
      tbl.Copy  
    'Paste Table into MS Word using inserted Bookmark
      oDoc.Bookmarks("BookmarkName").Range.PasteExcelTable _
        LinkedToExcel:=False, _
        WordFormatting:=False, _
        RTF:=False
Dave
 

chino3589

New Member
Joined
Oct 14, 2013
Messages
9
Thank you Dave! Not only it works great but my macro also run way faster. You have no idea how much I appreciate your answers. That was the Christmas miracle I needed!

Thank you and have a great Christmas time :)
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
2,723
You are welcome. Thanks for posting your miraculous outcome! Enjoy your Xmas and be safe. Dave
 

Watch MrExcel Video

Forum statistics

Threads
1,123,281
Messages
5,600,720
Members
414,401
Latest member
grenona2020

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top