View source for Saving JPEGs with GDI plus

Option Explicit

' ----==== API Declarations ====----

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 CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long

' ----==== SaveJPG ====----

Public Sub SaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80)
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
    ' Initialize GDI+
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI)
    
    If lRes = 0 Then
    
        ' Create the GDI+ bitmap
        ' from the image handle
        lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
        
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters
            
            ' Initialize the encoder GUID
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), _
                            tJpgEncoder
            
            ' Initialize the encoder parameters
            tParams.Count = 1
            With tParams.Parameter ' Quality
                ' Set the Quality GUID
                CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
                .NumberOfValues = 1
                .Type = 4
                .Value = VarPtr(quality)
            End With
            
            ' Save the image
            lRes = GdipSaveImageToFile( _
            lBitmap, _
            StrPtr(filename), _
            tJpgEncoder, _
            tParams)
            
            ' Destroy the bitmap
            GdipDisposeImage lBitmap
        End If
        
        ' Shutdown GDI+
        GdiplusShutdown lGDIP
    End If
    
    If lRes Then
        Err.Raise 5, , "Cannot save the image. GDI+ Error:" & lRes
    End If
End Sub