Option Explicit

'---------------- Описания структур, функций, констант Win32 API ---------------

Private Type Bitmap '24 bytes
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type

Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" ( _
   ByVal hObject As Long) As Long
Private Declare Function GetObjectA Lib "gdi32" ( _
   ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function GetObjectType Lib "gdi32" ( _
   ByVal hgdiobj As Long) As Long
Private Const OBJ_BITMAP =  7 

Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SetStretchBltMode Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Const STRETCH_DELETESCANS =  3 
Private Const STRETCH_HALFTONE =  4 

Private Declare Function StretchBlt Lib "gdi32" ( _
   ByVal hDC As Long, ByVal x As Long, ByVal y As Long, _
   ByVal nWidth As Long, ByVal nHeight As Long, _
   ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
   ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, _
   ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

Private Const PICTYPE_BITMAP =  1 

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( 7 ) As Byte
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
   PicDesc As PicBmp, RefIID As GUID, _
   ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

'-------------------------------------------------------------------------------

'Из Q161299
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CreateBitmapPicture
'    - Creates a bitmap type Picture object from a bitmap and
'      palette.
'
' hBmp
'    - Handle to a bitmap.
'
' hPal
'    - Handle to a Palette.
'    - Can be null if the bitmap doesn't use a palette.
'
' Returns
'    - Returns a Picture object containing the bitmap.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function CreateBitmapPicture( _
   ByVal hBmp As Long, ByVal hPal As Long) As StdPicture
 Dim R As Long
 Dim Pic As PicBmp
 ' IPicture requires a reference to "Standard OLE Types."
 Dim IPic As IPicture
 Dim IID_IDispatch As GUID

 ' Fill in with IDispatch Interface ID.
 With IID_IDispatch
    .Data1 = &H20400
    .Data4( 0 ) = &HC0
    .Data4( 7 ) = &H46
 End With

 ' Fill Pic with necessary parts.
 With Pic
    .Size = Len(Pic)          ' Length of structure.
    .Type = PICTYPE_BITMAP    ' Type of Picture (bitmap).
    .hBmp = hBmp              ' Handle to bitmap.
    .hPal = hPal              ' Handle to palette (may be null).
 End With

 ' Create Picture object.
 R = OleCreatePictureIndirect(Pic, IID_IDispatch,  1 , IPic)

 ' Return the new Picture object.
 Set CreateBitmapPicture = IPic
End Function


Public Function FitToSizeBitmap( _
   ByVal hBitmap As Long, _
   Optional ByVal nWidth As Long =  0 , _
   Optional ByVal nHeight As Long =  0 ) As StdPicture
 Dim bm As Bitmap
 Dim cbSize As Long
 Dim cbCopied As Long
 Dim hdcSrc As Long
 Dim hdcDst As Long
 Dim hbmpOldSrc As Long
 Dim hbmpOldDst As Long
 Dim hbmpNew As Long
 Dim r0 As Double
 Dim nDstWidth As Long, nDstHeight As Long

 If (hBitmap =  0 ) Or (nWidth <  0 ) Or (nHeight <  0 ) Then Exit Function
 If GetObjectType(hBitmap) <> OBJ_BITMAP Then Exit Function
 
 'Получаем заголовок битмапа, чтобы извлечь из него размеры изображения
 'в пикселях
 cbSize = LenB(bm)
 cbCopied = GetObjectA(hBitmap, cbSize, bm)
 If cbCopied <> cbSize Then Exit Function

 'Подгонка размера
 r0 = bm.bmWidth / bm.bmHeight
 If nWidth =  0  Then
    'Пользователя не интересует ширина - вписываем в высоту
    If nHeight =  0  Then
       'Пользователя не интересует и высота - странно. Просто
       'сохраняем оригинальные размеры
       nDstWidth = bm.bmWidth
       nDstHeight = bm.bmHeight
    Else
       nDstHeight = nHeight
       nDstWidth = Int(nDstHeight * r0 +  0 . 5 )
       If nDstWidth <=  0  Then nDstWidth =  1 
    End If
 ElseIf nHeight =  0  Then
    'Пользователя не интересует высота - вписываем в ширину
    nDstWidth = nWidth
    nDstHeight = Int(nDstWidth / r0 +  0 . 5 )
    If nDstHeight <=  0  Then nDstHeight =  1 
 Else
    'Пользователь хочет вписать битмап в прямоугольник с размерами
    'не больше заданных
    If r0 < nWidth / nHeight Then
       nDstHeight = nHeight
       nDstWidth = Int(nHeight * r0 +  0 . 5 )
       If nDstWidth <=  0  Then nDstWidth =  1 
    Else
       nDstWidth = nWidth
       nDstHeight = Int(nHeight / r0 +  0 . 5 )
       If nDstHeight <=  0  Then nDstHeight =  1 
    End If
 End If

 'Создаём контексты устройств, совместимых с экраном, в памяти
 'Картинка будет иметь логическое разрешение, как у экрана (обычно 96 dpi)
 hdcSrc = CreateCompatibleDC( 0 )
 hdcDst = CreateCompatibleDC(hdcSrc)
 
 'Создаём битмап, совместимый с оригинальным, в памяти
 hbmpOldSrc = SelectObject(hdcSrc, hBitmap)
 hbmpNew = CreateCompatibleBitmap(hdcSrc, nDstWidth, nDstHeight)
 If hbmpNew =  0  Then
    SelectObject hdcSrc, hbmpOldSrc
    DeleteDC hdcDst
    DeleteDC hdcSrc
    Exit Function
 End If
 hbmpOldDst = SelectObject(hdcDst, hbmpNew)

 'Отрисовываем оригинальный битмап на целевой с перемасштабированием
 SetStretchBltMode hdcDst, STRETCH_HALFTONE 'Есть только в ОС с ядром NT
 StretchBlt hdcDst,  0 ,  0 , nDstWidth, nDstHeight, _
            hdcSrc,  0 ,  0 , bm.bmWidth, bm.bmHeight, SRCCOPY

 'Создаём StdPicture, владеющий битмапом
 Set FitToSizeBitmap = CreateBitmapPicture(hbmpNew,  0 )
 
 'Очищаем объекты GDI
 SelectObject hdcSrc, hbmpOldSrc
 SelectObject hdcDst, hbmpOldDst
 'DeleteObject hbmpNew 'Третий параметр OleCreatePictureIndirect,
                      'установленний в TRUE, заставляет убивать битмап
                      'при уменьшении счётчика ссылок на картинку до нуля
 DeleteDC hdcDst
 DeleteDC hdcSrc
End Function

Public Sub Test()
 Dim SrcPic As StdPicture, DstPic As StdPicture
 Set SrcPic = LoadPicture("C:\test.jpg")
 Set DstPic = FitToSizeBitmap(SrcPic.Handle,  175 )
 SavePicture DstPic, "C:\test1.bmp"
End Sub

Option Explicit

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

Private Type CLSID 'частный вид GUID-а
   Data1         As Long
   Data2         As Integer
   Data3         As Integer
   Data4( 0  To  7 ) As Byte
End Type

Private Enum EncoderParameterValueType
   [EncoderParameterValueTypeByte] =  1 
   [EncoderParameterValueTypeASCII] =  2 
   [EncoderParameterValueTypeShort] =  3 
   [EncoderParameterValueTypeLong] =  4 
   [EncoderParameterValueTypeRational] =  5 
   [EncoderParameterValueTypeLongRange] =  6 
   [EncoderParameterValueTypeUndefined] =  7 
   [EncoderParameterValueTypeRationalRange] =  8 
End Enum

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

Private Type EncoderParameters
   Count     As Long
   Parameter As EncoderParameter
End Type

Private Enum GpStatus
   [OK] =  0 
   [GenericError] =  1 
   [InvalidParameter] =  2 
   [OutOfMemory] =  3 
   [ObjectBusy] =  4 
   [InsufficientBuffer] =  5 
   [NotImplemented] =  6 
   [Win32Error] =  7 
   [WrongState] =  8 
   [Aborted] =  9 
   [FileNotFound] =  10 
   [ValueOverflow] =  11 
   [AccessDenied] =  12 
   [UnknownImageFormat] =  13 
   [FontFamilyNotFound] =  14 
   [FontStyleNotFound] =  15 
   [NotTrueTypeFont] =  16 
   [UnsupportedGdiplusVersion] =  17 
   [GdiplusNotInitialized] =  18 
   [PropertyNotFound] =  19 
   [PropertyNotSupported] =  20 
End Enum
Private Type ImageCodecInfo
   ClassID           As CLSID
   FormatID          As CLSID
   CodecName         As Long
   DllName           As Long
   FormatDescription As Long
   FilenameExtension As Long
   MimeType          As Long
   flags             As Long
   Version           As Long
   SigCount          As Long
   SigSize           As Long
   SigPattern        As Long
   SigMask           As Long
End Type

Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" ( _
   ByVal hBmp As Long, ByVal hPal As Long, Bitmap As Long) As GpStatus
Private Declare Function GdiplusStartup Lib "gdiplus" ( _
   token As Long, inputbuf As GdiplusStartupInput, _
   Optional ByVal outputbuf As Long =  0 ) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" ( _
   ByVal token As Long) As GpStatus
Private Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
   ByVal image As Long, ByVal FileNameW As Long, _
   clsidEncoder As CLSID, encoderParams As Any) As GpStatus
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" ( _
   numEncoders As Long, Size As Long) As GpStatus
Private Declare Function GdipGetImageEncoders Lib "gdiplus" ( _
   ByVal numEncoders As Long, ByVal Size As Long, encoders As Any) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
   ByVal image As Long) As GpStatus

Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   Dest As Any, Src As Any, ByVal cb As Long) As Long
'Private Declare Function CLSIDFromString Lib "ole32" ( _
   ByVal lpszProgID As Long, pCLSID As CLSID) As Long
Private Declare Function lstrlenW Lib "kernel32" ( _
   ByVal psString As Any) As Long

'Private Const EncoderQuality$ = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private GdIHandle As Long

Public Function SavePictureToJPEG( _
   Picture As StdPicture, FileName As String, JPGQuality As Long) As Boolean
 Dim gplRet      As Long
 Dim hImg        As Long
 Dim uEncCLSID   As CLSID
 Dim uEncParams  As EncoderParameters

 Dim GpInput As GdiplusStartupInput
 GpInput.GdiplusVersion =  1 
 If GdiplusStartup(GdIHandle, GpInput) <> [OK] Then Exit Function
 If JPGQuality >  100  Then JPGQuality =  100 
 If JPGQuality <  1  Then JPGQuality =  1 

 '-- Create bitmap from HBITMAP
 gplRet = GdipCreateBitmapFromHBITMAP(Picture.Handle, Picture.hPal, hImg)
 If gplRet = [OK] Then
    
    GetEncoderClsID "image/jpeg", uEncCLSID
    'Установка качества
    uEncParams.Count =  1 
    With uEncParams.Parameter
       .NumberOfValues =  1 
       .Type = [EncoderParameterValueTypeLong]
       With .GUID
          .Data1 = &H1D5BE4B5
          .Data2 = &HFA4A
          .Data3 = &H452D
          .Data4( 0 ) = &H9C
          .Data4( 1 ) = &HDD
          .Data4( 2 ) = &H5D
          .Data4( 3 ) = &HB3
          .Data4( 4 ) = &H51
          .Data4( 5 ) = &H5
          .Data4( 6 ) = &HE7
          .Data4( 7 ) = &HEB
       End With
       'CLSIDFromString StrPtr(EncoderQuality), .GUID
       .Value = VarPtr(JPGQuality)
    End With
    gplRet = GdipSaveImageToFile(hImg, StrPtr(FileName), uEncCLSID, uEncParams)
    SavePictureToJPEG = gplRet = [OK]
    gplRet = GdipDisposeImage(hImg)
 End If
 
 GdiplusShutdown GdIHandle
End Function

Private Function GetEncoderClsID(strMimeType As String, ClassID As CLSID)
 Dim Num As Long, Size As Long, i As Long
 Dim ICI()    As ImageCodecInfo
 Dim Buffer() As Byte
 
 GetEncoderClsID = - 1 
 GdipGetImageEncodersSize Num, Size
 If Size =  0  Then Exit Function
 ReDim ICI( 1  To Num) As ImageCodecInfo
 ReDim Buffer( 1  To Size) As Byte
 GdipGetImageEncoders Num, Size, Buffer( 1 )
 CopyMemory ICI( 1 ), Buffer( 1 ), (Len(ICI( 1 )) * Num)
 For i =  1  To Num
    If StrComp(LPWSTR2String(ICI(i).MimeType), strMimeType, _
               vbTextCompare) =  0  Then
       ClassID = ICI(i).ClassID
       GetEncoderClsID = i
       Exit For
    End If
 Next
 Erase ICI
 Erase Buffer
End Function

Private Function LPWSTR2String(ByVal lpWStr As Long) As String
 Dim nStrLen As Long
 nStrLen = lstrlenW(lpWStr)
 LPWSTR2String = String$(nStrLen, vbNullChar)
 CopyMemory ByVal StrPtr(LPWSTR2String), ByVal lpWStr, nStrLen *  2 
End Function

Public Sub Test()
 Dim SrcPic As StdPicture, DstPic As StdPicture
 Set SrcPic = LoadPicture("C:\test.jpg")
 Set DstPic = FitToSizeBitmap(SrcPic.Handle,  175 )
 SavePicture DstPic, "C:\test1.bmp"
 SavePictureToJPEG  DstPic, "C:\test1.jpg",  80 
 Set DstPic = FitToSizeBitmap(SrcPic.Handle,  75 )
 SavePicture DstPic, "C:\test2.bmp"
 SavePictureToJPEG  DstPic, "C:\test2.jpg",  80 
End Sub