Option Explicit
'The subroutine to invoke is  GIF_Snapshot  to convert a range of cells to a .GIF file.
'Harold Staff -- see http://www.mvps.org/dmcritchie/excel/xl2gif.htm
'XL2GIF_module -- GIF_Snapshot
Dim container As Chart
Dim containerbok As Workbook
Dim Obnavn As String
Dim Sourcebok As Workbook

Function SelectArea() As String
Dim Internrange As Range
On Error GoTo Brutt
Set Internrange = Application.InputBox("Select " _
    & "range to be photographed:", "Picture Selection", _
    Selection.AddressLocal, Type:=8)
SelectArea = Internrange.Address
Exit Function
Brutt:
SelectArea = "A1"
End Function

Function sShortname(ByVal Orrginal As String) As String
Dim iii As Long
sShortname = ""
For iii = 1 To Len(Orrginal)
If Mid(Orrginal, iii, 1) <> " " Then _
      sShortname = sShortname & Mid(Orrginal, iii, 1)
Next
End Function

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 Long, iv As Long)
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 MySuggest As String
Dim Hi As Long
Dim Wi As Long
Dim Suffiks As Long

Set Sourcebok = ActiveWorkbook
MySuggest = sShortname(ActiveSheet.Name)
ImageContainer_init
Sourcebok.Activate
MyAddress = SelectArea
If MyAddress <> "A1" Then
    SaveName = Application.GetSaveAsFilename( _
      initialfilename:=MySuggest _
      & ".gif", fileFilter:="Gif Files (*.gif), *.gif")
    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
    ActiveChart.Export filename:=LCase(SaveName) & _
         ".gif", FilterName:="GIF"
    ActiveChart.Pictures(1).Delete
    Sourcebok.Activate
End If
Avbryt:
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
End Sub