Save Excel.Range to image file

Saving a Spreadsheet Range as a image file

Option Explicit 
 
Private Type PicBmp 
    Size As Long 
    Type As Long 
        hBmp As Long 
        hPal As Long 
        Reserved As Long 
    End Type 
     
    Private Type Guid 
        Data1 As Long 
        Data2 As Integer 
        Data3 As Integer 
        Data4(0 To 7) As Byte 
    End Type 
     
    Private Const CF_BITMAP = 2 
    Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _ 
    (PicDesc As PicBmp, RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long 
    Private Declare Function GetClipboardData Lib "user32"  _ 
    (ByVal wFormat As Long) As Long 
    Private Declare Function CloseClipboard Lib "user32" () As Long 
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long 
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ 
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
     
    Sub SaveImage(rng As Range, strFileName As String) 
        Dim hwnd As Long 
        Dim hPtr As Long 
        hwnd = FindWindow("xlmain", Application.Caption) 
        rng.CopyPicture xlScreen, xlBitmap 
        OpenClipboard hwnd 
        hPtr = GetClipboardData(CF_BITMAP) 
        SavePicture CreateBitmapPicture(hPtr), strFileName 
        CloseClipboard 
    End Sub 
     
     
    Function CreateBitmapPicture(ByVal hBmp As Long) As IPicture 
        Dim lngR As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid 
         
        With IID_IDispatch 
            .Data1 = &H20400; 
            .Data4(0) = &HC0; 
            .Data4(7) = &H46; 
        End With 
         
        With Pic 
            .Size = Len(Pic) 
            .Type = 1 
            .hBmp = hBmp 
        End With 
         
        lngR = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic) 
        Set CreateBitmapPicture = IPic 
    End Function 
     

SaveImage Sheet1.Range("A1:A8"), "C:Documents and settingsmarkdesktoptest.bmp" 

SavePicture Clipboard.GetData(vbCFBitmap), "C:Documents and settingsmarkdesktoptest2.bmp"

Sub SelectedRangeToImage()
    Dim tmpChart As Chart
    Dim n As Long
    Dim shCount As Long
    Dim sht As Worksheet
    Dim sh As Shape
    Dim fileSaveName As Variant
    Dim pic As Variant
    'Create temporary chart as canvas
    Set sht = Selection.Worksheet
    Selection.Copy
    sht.Pictures.Paste.Select
    Set sh = sht.Shapes(sht.Shapes.Count)
    Set tmpChart = Charts.Add
    tmpChart.ChartArea.Clear
    tmpChart.Name = "PicChart" & (Rnd() * 10000)
    Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=sht.Name)
    tmpChart.ChartArea.Width = sh.Width
    tmpChart.ChartArea.Height = sh.Height
    tmpChart.Parent.Border.LineStyle = 0
    'Paste range as image to chart
    sh.Copy
    tmpChart.ChartArea.Select
    tmpChart.Paste
    'Save chart image to file
    fileSaveName = Application.GetSaveAsFilename(fileFilter:="Image (*.jpg), *.jpg")
    If fileSaveName <> False Then
      tmpChart.Export Filename:=fileSaveName, FilterName:="jpg"
    End If
    'Clean up
    sht.Cells(1, 1).Activate
    sht.ChartObjects(sht.ChartObjects.Count).Delete
    sh.Delete
End Sub