save cell as gif

[tegger]

Is it possible to save the contents of one cell as a gif?

 

[zantor]

Hi Tegger,

One way to do it is to select the current cell, press ctrl-c, open
MS-Paint and press ctrl-v. Go to 'File', 'Save-As' and select the 'Gif'
format and save the file with the appropriate name.

Hope this will help you.

 

[Tom Ogilvy]

so the answer is no - not directly. You would have to paste it in a chart
object and use the export command to do it in VBA.

 

[Tom Ogilvy]

Harald Staff wrote some code to do this. It is hosted on David McRitchie's
site:

http://www.mvps.org/dmcritchie/excel/xl2gif.htm

keywords:
chartobject
gif
export

--
Regards,
Tom Ogilvy

Zantor,

This should get you going. You'll have to sort out the bit that hides
anything in the chart itself. Sometimes when I tried this there was data in
the chart, other times it was blank, and the bit where I tried to set the
plotarea size to 0 doesn't really work to hide the chart itself. Easy to
write some code to get rid of anything in the chart though.

Sub Test()
CopyRangeAsGif Selection, "c:\temp\test.gif"
End Sub

Sub CopyRangeAsGif(rngCells As Range, strLocation As String)
Dim chNew As Chart
Dim chObj As ChartObject
Dim lWidth As Long
Dim lHeight As Long
Dim nCounter As Integer
Dim shSource As Worksheet

On Error GoTo 0
If InStr(rngCells.Address, ",") > 0 Then
MsgBox "Non contiguous range not permitted"
Exit Sub
End If

With rngCells
For nCounter = 1 To .Columns.Count
lWidth = lWidth + .Columns(nCounter).Width
Next nCounter

For nCounter = 1 To .Rows.Count
lHeight = lHeight + .Rows(nCounter).Height
Next nCounter

End With

Set chNew = Charts.Add

chNew.Location Where:=xlLocationAsObject, Name:=rngCells.Parent.Name
Set shSource = rngCells.Parent
Set chObj = shSource.ChartObjects(shSource.ChartObjects.Count)
rngCells.CopyPicture xlScreen, xlPicture

With ActiveChart
.Paste
.ChartArea.Border.LineStyle = 0
.PlotArea.Width = 0
.PlotArea.Height = 0
End With

chObj.Width = lWidth + 2
chObj.Height = lHeight + 2
chObj.Chart.Export strLocation, "GIF", False

rngCells.Select
chObj.Delete
End Sub

 

[Robin Hammond]

Zantor,

Having seen Tom's post I lifted the clearcontents line from Harald's code
which sorts out the problem with the contents of the chart. This one seems
to work quite well.

Sub Test()
CopyRangeAsGif Selection, "c:\temp\test.gif"
End Sub

Sub CopyRangeAsGif(rngCells As Range, strLocation As String)
Dim chNew As Chart
Dim chObj As ChartObject
Dim lWidth As Long
Dim lHeight As Long
Dim nCounter As Integer
Dim shSource As Worksheet

On Error GoTo 0
If InStr(rngCells.Address, ",") > 0 Then
MsgBox "Non contiguous range not permitted"
Exit Sub
End If

With rngCells
For nCounter = 1 To .Columns.Count
lWidth = lWidth + .Columns(nCounter).Width
Next nCounter

For nCounter = 1 To .Rows.Count
lHeight = lHeight + .Rows(nCounter).Height
Next nCounter

End With

Set chNew = Charts.Add

chNew.Location Where:=xlLocationAsObject, Name:=rngCells.Parent.Name
Set shSource = rngCells.Parent
Set chObj = shSource.ChartObjects(shSource.ChartObjects.Count)
rngCells.CopyPicture xlScreen, xlPicture

With ActiveChart
.Paste
.ChartArea.Border.LineStyle = 0
.ChartArea.ClearContents
End With

chObj.Width = lWidth + 4
chObj.Height = lHeight + 4
chObj.Chart.Export strLocation, "GIF", False

rngCells.Select
chObj.Delete
End Sub

Robin Hammond
www.enhanceddatasystems.com
Check out our XspandXL add-in

Zantor,

This should get you going. You'll have to sort out the bit that hides
anything in the chart itself. Sometimes when I tried this there was data in
the chart, other times it was blank, and the bit where I tried to set the
plotarea size to 0 doesn't really work to hide the chart itself. Easy to
write some code to get rid of anything in the chart though.

Sub Test()
CopyRangeAsGif Selection, "c:\temp\test.gif"
End Sub

Sub CopyRangeAsGif(rngCells As Range, strLocation As String)
Dim chNew As Chart
Dim chObj As ChartObject
Dim lWidth As Long
Dim lHeight As Long
Dim nCounter As Integer
Dim shSource As Worksheet

On Error GoTo 0
If InStr(rngCells.Address, ",") > 0 Then
MsgBox "Non contiguous range not permitted"
Exit Sub
End If

With rngCells
For nCounter = 1 To .Columns.Count
lWidth = lWidth + .Columns(nCounter).Width
Next nCounter

For nCounter = 1 To .Rows.Count
lHeight = lHeight + .Rows(nCounter).Height
Next nCounter

End With

Set chNew = Charts.Add

chNew.Location Where:=xlLocationAsObject, Name:=rngCells.Parent.Name
Set shSource = rngCells.Parent
Set chObj = shSource.ChartObjects(shSource.ChartObjects.Count)
rngCells.CopyPicture xlScreen, xlPicture

With ActiveChart
.Paste
.ChartArea.Border.LineStyle = 0
.PlotArea.Width = 0
.PlotArea.Height = 0
End With

chObj.Width = lWidth + 2
chObj.Height = lHeight + 2
chObj.Chart.Export strLocation, "GIF", False

rngCells.Select
chObj.Delete
End Sub