Save range in a new workbook as .gif

[Gerencsér Gábor]

Hi there,
Hitting a CommandButton I would like to have the Print_Area on my sheet in
MyWorkbook.xls saved as MyWorkbook2006-02-09.gif.
(Unfortunately I don't have Adobe acrobat to make .pdf.)
For some reason the code below just does not work and I cannot fix it.
I would appreciate some advise.
I am working in Excel2003

Sub SaveRangeAsGIF()
Dim strDate As String
Dim MyPath, MyName, MyFullName, MyPathName
MyPath = Application.ActiveWorkbook.Path
MyName = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
strDate = Format(Date, "yyyy-mm-dd")
MyFullName = MyName & "-" & strDate & ".gif"
MyPathName = ThisWorkbook.Path & "\" & MyName & "-" & strDate & ".gif"
Response = MsgBox("Do you want to save the Print_Area as " & MyFullName,
vbYesNo, "GIFmaker")
If Response = vbYes Then
Range("Print_Area").Export FileName:=MyPathName, FilterName:="GIF"
End If
End Sub

Gabor

[Ron de Bruin]

Hi Gerencsér

Here is code to play with

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

Or this example that save as c:\range.gif

Sub Testing()
Application.ScreenUpdating = False
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Set ctoTheChartHolder = ActiveSheet.ChartObjects.Add(0, 0, 800, 600)

Set chtTheChart = ctoTheChartHolder.Chart

' Paste the picture onto the chart and
' set an object variable for it
ctoTheChartHolder.Activate
With chtTheChart
.ChartArea.Select
.Paste
Set picThePicture = .Pictures(1)
End With

' Set the picture's properties...
With picThePicture
.Left = 0
.Top = 0
sglWidth = .Width + 7
sglHeight = .Height + 7
End With

' Change the size of the chart object to fit the picture
'better
With ctoTheChartHolder
.Border.LineStyle = xlNone
.Width = sglWidth
.Height = sglHeight
End With
' Export the chart as a graphics file
blnRet = chtTheChart.Export(Filename:="c:\range.gif", _
FilterName:="gif", Interactive:=False)
ctoTheChartHolder.Delete
Application.ScreenUpdating = True
End Sub

--
Regards Ron de Bruin
http://www.rondebruin.nl

"Gerencsér Gábor" <evag...@t-online.hu> wrote in message news:dsg964$ljk$1...@namru.matavnet.hu...

[Gerencsér Gábor]

Ron,
I modified the one at your place and now it works like I wanted.
Thank you
Here is my version:

Dim container As Chart
Dim containerbok As Workbook
Dim Obnavn As String
Dim Sourcebok As Workbook

Private Sub ImageContainer_init()
Workbooks.Add (1)
ActiveSheet.Name = "GIFcontainer"
Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Worksheets(1).Range("A1")
ActiveChart.Location Where:=xlLocationAsObject, _
Name:="GIFcontainer"
ActiveChart.ChartArea.ClearContents
Set containerbok = ActiveWorkbook
Set container = ActiveChart
End Sub

Sub MakeAndSizeChart(ih As Integer, iv As Integer)
Dim Hincrease As Single
Dim Vincrease As Single
Obnavn = Mid(ActiveChart.Name, Len(ActiveSheet.Name) + 1)
Hincrease = ih / ActiveChart.ChartArea.Height
ActiveSheet.Shapes(Obnavn).ScaleHeight Hincrease, _
msoFalse, msoScaleFromTopLeft
Vincrease = iv / ActiveChart.ChartArea.Width
ActiveSheet.Shapes(Obnavn).ScaleWidth Vincrease, _
msoFalse, msoScaleFromTopLeft
End Sub

Public Sub GIF_Snapshot()
Dim varReturn As Variant
Dim MyAddress As String
Dim SaveName As Variant '''''
Dim Hi As Integer
Dim Wi As Integer
Dim os

Dim strDate As String
Dim MyPath, MyName, MyFullName, MyPathName As String
Dim Response
os = ActiveCell.Address

MyPath = Application.ActiveWorkbook.Path
MyName = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
strDate = Format(Date, "yyyy-mm-dd")
MyFullName = MyName & "-" & strDate & ".gif"
MyPathName = ThisWorkbook.Path & "\" & MyName & "-" & strDate & ".gif"

Response = MsgBox("Do you want to save the Print_Area as " & MyFullName,
vbYesNo, "GIFmaker")

If Response = vbNo Then End

Set Sourcebok = ActiveWorkbook
ImageContainer_init
Sourcebok.Activate
MyAddress = Range("Print_Area").Address
If MyAddress <> "A1" Then
ChDir (ThisWorkbook.Path)
SaveName = MyFullName
Range(MyAddress).Select
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
If SaveName = False Then
GoTo Avbryt
End If
If InStr(SaveName, ".") Then SaveName _
= Left(SaveName, InStr(SaveName, ".") - 1)
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
Hi = Selection.Height + 4 'adjustment for gridlines
Wi = Selection.Width + 6 'adjustment for gridlines
containerbok.Activate
ActiveSheet.ChartObjects(1).Activate
MakeAndSizeChart ih:=Hi, iv:=Wi
ActiveChart.Paste
ChDir (Sourcebok.Path)
ActiveChart.Export Filename:=MyPathName, FilterName:="GIF"
ActiveChart.Pictures(1).Delete
Sourcebok.Activate
End If
Avbryt:
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
Range(os).Select
End Sub