Attribute VB_Name = "SaveAsJpg"
Option Explicit

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

Private Type EncoderParameter
   GUID As GUID
   NumberOfValues As Long
   Type As Long
   Value As Long
End Type

Private Type EncoderParameters
   Count As Long
   Parameter As EncoderParameter
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" ( _
   token As Long, _
   inputbuf As GdiplusStartupInput, _
   Optional ByVal outputbuf As Long = 0) As Long

Private Declare Function GdiplusShutdown Lib "GDIPlus" ( _
   ByVal token As Long) As Long

Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" ( _
   ByVal hbm As Long, _
   ByVal hPal As Long, _
   Bitmap As Long) As Long

Private Declare Function GdipDisposeImage Lib "GDIPlus" ( _
   ByVal Image As Long) As Long

Private Declare Function GdipSaveImageToFile Lib "GDIPlus" ( _
   ByVal Image As Long, _
   ByVal filename As Long, _
   clsidEncoder As GUID, _
   encoderParams As Any) As Long
   
Private Declare Function GdipSaveImageToStream Lib "GDIPlus" ( _
   ByVal Image As Long, _
   ByVal stream As Long, _
   clsidEncoder As GUID, _
   encoderParams As Any) As Long

Private Declare Function CreateStreamOnHGlobal Lib "ole32" ( _
   ByVal hGlobal As Long, _
   ByVal fDeleteOnRelease As Long, _
   ppstm As Any) As Long
   
Private Declare Function GetHGlobalFromStream Lib "ole32" ( _
   ByVal pstm As Long, _
   phglobal As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   lpDest As Any, lpSource As Any, _
   ByVal cbCopy As Long)

Private Declare Function CLSIDFromString Lib "ole32" ( _
   ByVal str As Long, _
   id As GUID) As Long
   
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Public Sub SaveJPGToMemory(ByVal pict As StdPicture, data() As Byte, Optional ByVal quality As Byte = 100)

Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long

   ' Инициализируем GDI+
   tSI.GdiplusVersion = 1
   lRes = GdiplusStartup(lGDIP, tSI)

   If lRes = 0 Then

      ' Создаем GDI+ текстуру по хендлеру изображения
      lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)

      If lRes = 0 Then
         Dim tJpgEncoder As GUID
         Dim tParams As EncoderParameters
         Dim pStream As Long, hMem As Long, Size As Long
         
         ' Инициализируем GUID энкодера
         CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder

         ' Инициализируем параметры
         tParams.Count = 1
         With tParams.Parameter
            ' Устанавливаем качество сжатия
            CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
            .NumberOfValues = 1
            .Type = 4
            .Value = VarPtr(quality)
         End With
         
         ' Сохраняем изображение в массив
         CreateStreamOnHGlobal 0, 1, pStream
         lRes = GdipSaveImageToStream(lBitmap, pStream, tJpgEncoder, tParams)
         lRes = GetHGlobalFromStream(pStream, hMem)
         Size = GlobalSize(hMem)
         ReDim data(0 To Size - 1)
         CopyMemory data(0), ByVal GlobalLock(hMem), Size
         GlobalUnlock hMem
         GlobalFree hMem
         
         ' Уничтожаем текстуру
         GdipDisposeImage lBitmap
      End If
      ' Отключаем GDI+
      GdiplusShutdown lGDIP
   End If
   If lRes Then
      Err.Raise 5, , "Cannot save the image. GDI+ Error:" & lRes
   End If
   
End Sub



