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 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
Const CF_BITMAP = 2
Const PICTYPE_BITMAP = 1
Dim strPictureFile As String
Public Sub SaveSheetAsImage(sh As Worksheet)
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim hPtr As Long
    Dim FilePathName$
    sh.UsedRange.CopyPicture Appearance:=xlScreen, format:=xlBitmap
    FilePathName = Application.GetSaveAsFilename("%homepath%\Pictures\", "Рисунок в формате GPEG (*.jpg), *.jpg", , "Сохраненеие изображения", "Сохранить")
    If FilePathName = "False" Then Exit Sub
    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
    SavePicture IPic, FilePathName
End Sub