Attribute VB_Name = "GdiPlus"
'==MODULE CODE==
'GDI+ Declares and types used in saving an image to JPEG in VB6
''' Translated by Avery P. - 7/29/2002
''' From the module GDIPLUS API.BAS
''' Available at psc.com
''' Edited by Erick37 October, 2004
''' experts-exchange.com

Option Explicit

' NOTE: Enums evaluate to a Long
Public Enum GpStatus   ' aka Status
   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

Public Type GdiplusStartupInput
   GdiplusVersion As Long              ' Must be 1 for GDI+ v1.0, the current version as of this writing.
   DebugEventCallback As Long          ' Ignored on free builds
   SuppressBackgroundThread As Long    ' FALSE unless you're prepared to call
                                       ' the hook/unhook functions properly
   SuppressExternalCodecs As Long      ' FALSE unless you want GDI+ only to use
                                       ' its internal image codecs.
End Type

Public Type CLSID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

' Information flags about image codecs
Public Enum ImageCodecFlags
   ImageCodecFlagsEncoder = &H1
   ImageCodecFlagsDecoder = &H2
   ImageCodecFlagsSupportBitmap = &H4
   ImageCodecFlagsSupportVector = &H8
   ImageCodecFlagsSeekableEncode = &H10
   ImageCodecFlagsBlockingDecode = &H20

   ImageCodecFlagsBuiltin = &H10000
   ImageCodecFlagsSystem = &H20000
   ImageCodecFlagsUser = &H40000
End Enum

Public Type ImageCodecInfo
   ClassID As CLSID
   FormatID As CLSID
   CodecName As Long      ' String Pointer; const WCHAR*
   DllName As Long        ' String Pointer; const WCHAR*
   FormatDescription As Long ' String Pointer; const WCHAR*
   FilenameExtension As Long ' String Pointer; const WCHAR*
   MimeType As Long       ' String Pointer; const WCHAR*
   flags As ImageCodecFlags   ' Should be a Long equivalent
   Version As Long
   SigCount As Long
   SigSize As Long
   SigPattern As Long      ' Byte Array Pointer; BYTE*
   SigMask As Long         ' Byte Array Pointer; BYTE*
End Type

' Image encoder parameter related types
Public Enum EncoderParameterValueType
   EncoderParameterValueTypeByte = 1              ' 8-bit unsigned int
   EncoderParameterValueTypeASCII = 2             ' 8-bit byte containing one 7-bit ASCII
                                                   ' code. NULL terminated.
   EncoderParameterValueTypeShort = 3             ' 16-bit unsigned int
   EncoderParameterValueTypeLong = 4              ' 32-bit unsigned int
   EncoderParameterValueTypeRational = 5          ' Two Longs. The first Long is the
                                                   ' numerator the second Long expresses the
                                                   ' denomintor.
   EncoderParameterValueTypeLongRange = 6         ' Two longs which specify a range of
                                                   ' integer values. The first Long specifies
                                                   ' the lower end and the second one
                                                   ' specifies the higher end. All values
                                                   ' are inclusive at both ends
   EncoderParameterValueTypeUndefined = 7         ' 8-bit byte that can take any value
                                                   ' depending on field definition
   EncoderParameterValueTypeRationalRange = 8      ' Two Rationals. The first Rational
                                                   ' specifies the lower end and the second
                                                   ' specifies the higher end. All values
                                                   ' are inclusive at both ends
End Enum

' Encoder Parameter structure
Public Type EncoderParameter
   GUID As CLSID                          ' GUID of the parameter
   NumberOfValues As Long                 ' Number of the parameter values; usually 1
   type As EncoderParameterValueType      ' Value type, like ValueTypeLONG  etc.
   value As Long                          ' A pointer to the parameter values
End Type

' Encoder Parameters structure
Public Type EncoderParameters
   Count As Long                          ' Number of parameters in this structure; Should be 1
   Parameter As EncoderParameter          ' Parameter values; this CAN be an array!!!! (Use CopyMemory and a string or byte array as workaround)
End Type

Public Const EncoderQuality           As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Public Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As GpStatus
Public Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal Filename As String, clsidEncoder As CLSID, encoderParams As Any) As GpStatus
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Public Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As GpStatus
Public Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, encoders As Any) As GpStatus
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal psString As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpszProgID As Long, pCLSID As CLSID) As Long
'
'
'Needed for GDI+
Private token As Long

'
'
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'By Erick37

Public Function DEFINE_GUID(ByVal sGuid As String) As CLSID
   ' Example ImageFormatBMP = {B96B3CAB-0728-11D3-9D7B-0000F81EF32E}
   Call CLSIDFromString(StrPtr(sGuid), DEFINE_GUID)
End Function

' From www.mvps.org/vbnet...i think
'   Dereferences an ANSI or Unicode string pointer
'   and returns a normal VB BSTR

Public Function gdipLoad() As Boolean

    ' Load the GDI+ Dll
    '
    'Return True for success, False for failure
    '
    Dim GpInput As GdiplusStartupInput

    gdipLoad = False
    GpInput.GdiplusVersion = 1
    If GdiplusStartup(token, GpInput) = Ok Then
        gdipLoad = True
    End If

End Function

Public Sub gdipUnLoad()
    ' Unload the GDI+ Dll
    Call GdiplusShutdown(token)
End Sub

Public 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 'Failure flag

   ' Get the encoder array size
   Call GdipGetImageEncodersSize(num, Size)
   If Size = 0 Then Exit Function ' Failed!

   ' Allocate room for the arrays dynamically
   ReDim ICI(1 To num) As ImageCodecInfo
   ReDim Buffer(1 To Size) As Byte

   ' Get the array and string data
   Call GdipGetImageEncoders(num, Size, Buffer(1))
   ' Copy the class headers
   Call CopyMemory(ICI(1), Buffer(1), (Len(ICI(1)) * num))

   ' Loop through all the codecs
   For I = 1 To num
      ' Must convert the pointer into a usable string
      If StrComp(PtrToStrW(ICI(I).MimeType), strMimeType, vbTextCompare) = 0 Then
         ClassID = ICI(I).ClassID   ' Save the class id
         GetEncoderClsid = I        ' return the index number for success
         Exit For
      End If
   Next
   ' Free the memory
   Erase ICI
   Erase Buffer
End Function

' Courtesy of: Dana Seaman
' Helper routine to convert a CLSID(aka GUID) string to a structure

Public Function PtrToStrW(ByVal lpsz As Long) As String
    Dim sOut As String
    Dim lLen As Long

    lLen = lstrlenW(lpsz)

    If (lLen > 0) Then
        sOut = StrConv(String$(lLen, vbNullChar), vbUnicode)
        Call CopyMemory(ByVal sOut, ByVal lpsz, lLen * 2)
        PtrToStrW = StrConv(sOut, vbFromUnicode)
    End If
End Function

Public Function SaveAsJPEG(Picture As IPicture, ByVal Filename As String, Optional ByVal Quality As Long = 80) As Long
    '
    'Saves picturebox image as JPEG using GDI+
    '
    Dim stat As GpStatus
    Dim bm As Long
    Dim encoderCLSID As CLSID
    Dim encoderParams As EncoderParameters
    Dim lQuality As Long

    'get the picture into a GDI+ image
    stat = GdipCreateBitmapFromHBITMAP(Picture.Handle, Picture.hpal, bm)

    ' Get the CLSID of the JPEG encoder
    Call GetEncoderClsid("image/jpeg", encoderCLSID)

    ' Setup the encoder paramters for JPEG quality
    If (stat = Ok) Then
        lQuality = Quality
        encoderParams.Count = 1    ' Only one element in this Parameter array
        With encoderParams.Parameter
            .NumberOfValues = 1     ' Should be one
            .type = EncoderParameterValueTypeLong
            ' Set the GUID to EncoderQuality
            .GUID = DEFINE_GUID(EncoderQuality)
            .value = VarPtr(lQuality)  ' Remember: The value expects only pointers!
        End With

        ' Now save the bitmap as JPEG
        stat = GdipSaveImageToFile(bm, StrConv(Filename, vbUnicode), encoderCLSID, encoderParams)

    End If

    SaveAsJPEG = stat

    ' Cleanup
    Call GdipDisposeImage(bm)
End Function