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)
   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
   Call Error_Handle(msMODULENAME, sProcName, Err.Number, Err.Description)
End Sub

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext