CODEWITHSUNDEEP
excelvba
Shaun McConnell
Shaun McConnell

Reputation: 11

Copy range of cells into picture

I select a range, copy into chart (as picture), save the picture as .jpg to network drive, then delete object.

The code works 95% of the time, but occasionally gets hung on sht.Pictures.Paste.Select.

Says 1004, can not paste.

Option Explicit
Sub RangeToImage()
    Application.OnTime Now + TimeSerial(0, 0, 30), "RangeToImage"
    Dim tmpChart As Chart, n As Long, shCount As Long, sht As Worksheet, sh As Shape
    Dim fileSaveName As Variant, pic As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Workbooks("G2_Live_Data.xlsm").Activate
    Set sht = Worksheets("DashboardData")
    sht.Range("A1:AE65").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

    sh.Copy
    tmpChart.ChartArea.Select
    tmpChart.Paste

    fileSaveName = "O:\8700_Manufacturing_Engineeri\02_KIM1_G2_DataTracking\G2LiveDashboard.jpg"
    If fileSaveName <> False Then
      tmpChart.Export Filename:=fileSaveName, FilterName:="jpg"
    End If


    sht.Cells(1, 1).Activate
    sht.ChartObjects(sht.ChartObjects.Count).Delete
    sh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Upvotes: 0

Views: 191

Answers (1)

Shaun McConnell
Shaun McConnell

Reputation: 11

I added a two second wait between copy/paste.

My Excel sheet is using DDE links to gather data from a manufacturing PLC, so I think Excel was "freezing" or not able to paste a blank image, due to the amount of data transfer from the DDE link.

Just a guess, but so far it's working. 

Option Explicit

Sub RangeToImage()
    Application.OnTime Now + TimeSerial(0, 0, 30), "RangeToImage"
    Dim tmpChart As Chart, n As Long, shCount As Long, sht As Worksheet, sh As Shape
    Dim fileSaveName As Variant, pic As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Workbooks("G2_Live_Data.xlsm").Activate
    Set sht = Worksheets("DashboardData")
    sht.Range("A1:AE65").Copy

    Application.Wait (Now + TimeValue("0:00:2"))

    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

    sh.Copy
    tmpChart.ChartArea.Select
    tmpChart.Paste

    fileSaveName = "O:\8700_Manufacturing_Engineeri\02_KIM1_G2_DataTracking\G2LiveDashboard.jpg"
    If fileSaveName <> False Then
      tmpChart.Export Filename:=fileSaveName, FilterName:="jpg"
    End If

    sht.Cells(1, 1).Activate
    sht.ChartObjects(sht.ChartObjects.Count).Delete
    sh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    End Sub

Upvotes: 1

Related Questions