Macro - Copy cell area and export to bitmap or any other graphic file?

[Dno]

Hi,

I've seen a macro before that was named selectcopy and what it did was when you select and area of cells you could click the happy face button and it would automatically open up a file save prompt.

Then you could choose to save as a bitmap or jpg. Then it would export only the selected area to bitmap.

Does anyone know of a macro that does this by chance or a better way to go about it?

Thanks!

Dino

[Vlad999]

Heres something I found I have changed it from GIF to JPG if you want BMP just change all instances of JPG to BMP (I have highlighted these in red for you.

Option Explicit
'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 Integer
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 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 JPG_Snapshot()
Dim varReturn As Variant
Dim MyAddress As String
Dim SaveName As Variant
Dim MySuggest As String
Dim Hi As Integer
Dim Wi As Integer
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 _
      & ".jpg", fileFilter:="jpg Files (*.jpg), *.jpg")
    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) & _
         ".jpg", FilterName:="jpg"
    ActiveChart.Pictures(1).Delete
    Sourcebok.Activate
End If
Avbryt:
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
End Sub