Saving ranges as GIFs

B

Ben

Sub SaveChartAsGIF()
Fname = ThisWorkbook.Path & "\" & ActiveChart.Name & ".gif"
ActiveChart.Export Filename:=Fname, FilterName:="GIF"
End Sub

I'd like to adapt the above code so that it acts on a linked range of data
rather than a chart. I created the data range from an existing area of a
worksheet using the Camera tool. The objective is to save the data range as a
static picture so that I can use it in other applications. It would be more
helpful if the macro could refer to these ranges by a name rather than having
to manually activate the ranges. I am familiar with the process of renaming a
chart object instead of it being called "Chart1" etc I asssume that I would
follow the same convention in renaming these linked data ranges. Thanks in
advance for any help.
 
B

Ben

Your suggestion would be a step in the right direction but ideally I would
like to have the macro automate the process of writing the ranges to a folder
as GIfs or JPGs etc in the same way as in the example code that I submitted.
 
O

okaizawa

Hi,

in excel 2000 and later versions, you can create a picture by copying
and pasting, and save it as a part of a web page. (no options for the
quality like compression ratio)
for example,

Sub SavePicture(Target As Object, Filename As String, _
Optional CopyBitmap As Boolean = False)
Dim TmpHtml As String, TmpFolder As String
Dim TmpFile As String, PictureFormat As String

TmpHtml = ThisWorkbook.Path & "\_tmp.htm"
TmpFolder = ThisWorkbook.Path & "\_tmp.files"

Select Case UCase(Right(Filename, 3))
Case "GIF": PictureFormat = "Picture (GIF)"
Case "JPG": PictureFormat = "Picture (JPEG)"
Case "PNG": PictureFormat = "Picture (PNG)"
Case Else: Exit Sub
End Select

If CopyBitmap Then
Target.CopyPicture xlScreen, xlBitmap
Else
Target.CopyPicture xlScreen, xlPicture
End If

Application.ScreenUpdating = False
With Workbooks.Add(xlWorksheet)
With .Worksheets(1)
.Paste
Selection.Cut
.PasteSpecial PictureFormat
End With
Application.DisplayAlerts = False
.SaveAs Filename:=TmpHtml, FileFormat:=xlHtml
.Close False
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True

TmpFile = Dir(TmpFolder & "\*." & Right(Filename, 3))
If TmpFile <> "" Then
FileCopy TmpFolder & "\" & TmpFile, Filename
End If

On Error Resume Next
Kill TmpFolder & "\*.*"
Kill TmpHtml
RmDir TmpFolder
On Error GoTo 0
End Sub

Sub Test_SavePicture()
If ThisWorkbook.Path = "" Then Exit Sub
SavePicture Range("A1:C10"), ThisWorkbook.Path & "\range.gif"
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top