Save range of cells to clipboard as image

[Nate62246]

I am trying to use a bit of VBA to copy a range of cells as an image to paste into a non-Microsoft program. The code below works on occasion but errors out 90% of the time on "sh.Copy". It appears as though it isn't always picking up my range of cells and defining them as "sh".
What am I missing?

'create jpg for selected range
'==================================================

Dim tmpChart As Chart, n As Long, shCount As Long, sht As Worksheet, sh As Shape
Dim fileSaveName As Variant, pic As Variant

'Sets the Excel Copy Range
     FCF.Range("B1:G" & (FCF.Range("B3").End(xlDown).Row)).SpecialCells(xlCellTypeVisible).Select

'Create temporary chart as canvas
Set sht = Selection.Worksheet
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

'Selection Copy
sht.Pictures.Paste.Select
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.Copy
tmpChart.ChartArea.Select
tmpChart.Paste

'Create folder location
myfoldername = Environ("userprofile") & "\Desktop\Facility Care Forms"

'create file name
myfilename = Sheets("Facility Care Form").Range("B2 ").Text & _
Format(Now(), " mmm-dd-yyyy hhmmss") & ".jpg"

'Check to see if folder name exists already. If not, create it
If Dir(myfoldername, vbDirectory) = "" Then MkDir myfoldername

'Save file
    fileSaveName = myfoldername & "\" & myfilename

'Save chart image to file
If fileSaveName <> False Then
tmpChart.Export Filename:=fileSaveName, FilterName:="jpg"
End If

'Clean up
sht.Cells(1, 1).Activate
sht.ChartObjects(sht.ChartObjects.Count).Delete
sh.Delete

 

[NdNoviceHlp]

HTH. Dave
Copy range as jpg without creating/deleting chart? | Page 4 | MrExcel Message Board

 

[Nate62246]

The template may work if I can use once for the xlsm and once for the jpg.

I added save function part of the code to before the FCF.Range part. This solved the issue, of the copy paste function working correctly. When I did this, it allowed the copy paste code to work flawlessly every time. However in saving both of these to the Environ("userprofile") worked for me, but unfortunately only worked for 2 of the other 5 that tried it. All others it errored out as location not found.

section for xslm to save and reset for copy paste to work, allowing sht.shapes.count to equal 3

'Create folder location
    myfoldername = Environ("userprofile") & "\Desktop\Facility Care Forms_Temp"
'create file name
    myfilename = "Facility Care Form-CT Suite.xlsm"
'Check to see if folder name exists already.  If not, create it
    If Dir(myfoldername, vbDirectory) = "" Then MkDir myfoldername
'Save file
    ActiveWorkbook.SaveAs Filename:=myfoldername & "\" & myfilename, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

section for jpg to save and be available on clipboard

 

[Nate62246]

Not sure if section for jpg to save and be available on clipboard copied to message board

'Create folder location
    myfoldername = Environ("userprofile") & "\Desktop\Facility Care Forms_Temp"
'create file name
    myfilename = Sheets("Facility Care Form").Range("B2 ").Text & _
    Format(Now(), " mmm-dd-yyyy hhmmss") & ".jpg"
'Check to see if folder name exists already.  If not, create it
    If Dir(myfoldername, vbDirectory) = "" Then MkDir myfoldername
'Save file
    fileSaveName = myfoldername & "\" & myfilename
'Save chart image to file
    If fileSaveName <> False Then
      tmpChart.Export Filename:=fileSaveName, FilterName:="jpg"
    End If

 

[Nate62246]

Ok here's where I am at. The above folder location code works as it should. The errors I am receiving from other users is because they are working on remote desktops and the file structure is different from mine. To solve for this, I modified myfoldername to: myfoldername = "C:\TempFolder"

To correct the issue of sht.shapes.count not showing a consistent value, I have trigged the file to be saved to the temp folder prior to doing the sht.shapes.count.

File is working correctly now. Thanks for all the help everyone!