Saving

This lets you save a range of cells as a picture.

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long 
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long 
Private Declare Function CloseClipboard Lib "user32" () As Long 
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long 

Private Type GUID 
    Data1 As Long 
    Data2 As Integer 
    Data3 As Integer 
    Data4(0 To 7) As Byte 
End Type 
Private Type uPicDesc 
    Size As Long 
    Type As Long 
    hPic As Long 
    hPal As Long 
End Type 
Private Const CF_BITMAP = 2 
Private Const PICTYPE_BITMAP = 1 
Public strChrtTag1 As String 
Public strChrtTag2 As String 

Public Sub SaveRangePic(SourceRange As Range, FilePathName As String) 
Const sProcName As String = "SaveRangePic" 
Dim IID_IDispatch As GUID 
Dim uPicInfo As uPicDesc 
Dim IPic As IPicture 
Dim hPtr As Long 
   On Error GoTo ErrorHandler 
   SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap 
   OpenClipboard 0 
   hPtr = GetClipboardData(CF_BITMAP) 
   CloseClipboard 
   With IID_IDispatch 
       .Data1 = &H7BF80980 
       .Data2 = &HBF32 
       .Data3 = &H101A 
       .Data4(0) = &H8B 
       .Data4(1) = &HBB 
       .Data4(2) = &H0 
       .Data4(3) = &HAA 
       .Data4(4) = &H0 
       .Data4(5) = &H30 
       .Data4(6) = &HC 
       .Data4(7) = &HAB 
   End With 
   With uPicInfo 
       .Size = Len(uPicInfo) 
       .Type = PICTYPE_BITMAP 
       .hPic = hPtr 
       .hPal = 0 
   End With 
   OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic 
   stdole.SavePicture IPic, FilePathName 
   Exit Sub 
ErrorHandler: 
   Call Error_Handle(msMODULENAME, sProcName, Err.Number, Err.Description) 
End Sub