CODEWITHSUNDEEP
vbaexcel
Rohan
Rohan

Reputation: 319

Save image of range in next column excel vba

On the activesheet in column A, I have text of which I want to save image and place it in column B.

I can't figure out how to remove the lines and axis etc and just get a image of the range. Currently it's showing lines and axis in the image.

Sub Generate_Images()

Dim wK As Worksheet
Dim oCht As Chart
Dim i As Long, fI As Long
Dim fName As String

Application.DisplayAlerts = False
Set wK = ActiveSheet

fI = wK.Range("A" & wK.Rows.Count).End(xlUp).Row
wK.Columns("B:B").ColumnWidth = wK.Columns("A:A").ColumnWidth

For i = 1 To fI

    wK.Range("A" & i).CopyPicture xlScreen, xlBitmap
    Set oCht = ThisWorkbook.Charts.Add

    With oCht
        .ChartArea.Border.LineStyle = xlNone
        .Paste
        fName = ThisWorkbook.Path & "\" & Format(Now(), "DDMMYYHHMMSS") & ".png"
        .Export Filename:=fName, Filtername:="PNG"
        .Delete
    End With

    With wK.Pictures.Insert(fName)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = wK.Range("A" & i).Width
            .Height = wK.Range("A" & i).Height
        End With
        .Left = wK.Range("B" & i).Left
        .Top = wK.Range("B" & i).Top
        .Placement = 1
        .PrintObject = True
    End With

    Application.Wait Now + TimeValue("00:00:01")
Next i

    Application.DisplayAlerts = True

End Sub

Upvotes: 0

Views: 70

Answers (2)

Dy.Lee
Dy.Lee

Reputation: 7567

If you save image to picture file, then try this.

Instead Chart, use chartobject. It is possible to change chart's size. And if your active cell is not empty, Excell automatically create chart base on data. So, you must delete chart's seriescollecton.

Sub Generate_Images()

Dim wK As Worksheet
Dim oCht As Chart
Dim i As Long, fI As Long, j As Long
Dim fName As String
Dim obj As ChartObject
Dim n As Long
Dim w As Single, h As Single

Application.DisplayAlerts = False
Set wK = ActiveSheet

wK.Pictures.Delete
fI = wK.Range("A" & wK.Rows.Count).End(xlUp).Row
wK.Columns("B:B").ColumnWidth = wK.Columns("A:A").ColumnWidth

For i = 1 To fI
w = wK.Range("A" & i).Width
h = wK.Range("A" & i).Height
    wK.Range("A" & i).CopyPicture xlScreen, xlBitmap

    Set obj = wK.ChartObjects.Add(Range("c1").Left, 0, w, h)
    Set oCht = obj.Chart
    With oCht
        n = .SeriesCollection.Count
        For j = n To 1 Step -1
            .SeriesCollection(j).Delete
        Next j
        .ChartArea.Border.LineStyle = xlNone
        .Paste
        fName = ThisWorkbook.Path & "\" & Format(Now(), "DDMMYYHHMMSS") & ".png"
        .Export Filename:=fName, Filtername:="PNG"
        obj.Delete
    End With

    With wK.Pictures.Insert(fName)
        .Left = wK.Range("B" & i).Left
        .Top = wK.Range("B" & i).Top
        .Placement = 1
        .PrintObject = True
    End With

    Application.Wait Now + TimeValue("00:00:01")
Next i

    Application.DisplayAlerts = True

End Sub

Upvotes: 0

Tim Williams
Tim Williams

Reputation: 166126

Why export and then re-import the image when you can just paste it straight into the sheet?

Sub Generate_Images()

    Dim wK As Worksheet
    Dim oCht As Chart
    Dim i As Long, fI As Long
    Dim fName As String

    Application.DisplayAlerts = False
    Set wK = ActiveSheet

    fI = wK.Range("A" & wK.Rows.Count).End(xlUp).Row
    wK.Columns("B:B").ColumnWidth = wK.Columns("A:A").ColumnWidth

    For i = 1 To fI

        wK.Range("A" & i).CopyPicture xlScreen, xlBitmap
        wK.Paste

        With wK.Pictures(wK.Pictures.Count)
            .Left = wK.Range("B" & i).Left
            .Top = wK.Range("B" & i).Top
            .Placement = 1
            .PrintObject = True
        End With

        Application.Wait Now + TimeValue("00:00:01")
    Next i

    Application.DisplayAlerts = True

End Sub

Upvotes: 2

Related Questions