VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cGdiPlus"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (lpPictDesc As PICDESC, riid As CLSID, ByVal fOwn As Long, ByRef lplpvObj As Any)

Event Error(ByVal lGdiError As Long, ByVal sErrorDesc As String)

Dim m_lToken        As Long
Dim tGuids()        As CLSID
Dim colCodecs       As Collection
Dim m_lNumCodecs    As Long
'

Private Sub Class_Initialize()
  Dim gsi       As GdiplusStartupInput
  Dim lError    As Long
  
  gsi.GdiplusVersion = 1
  lError = GdiplusStartup(m_lToken, gsi, ByVal 0)
  
  If Not lError Then
    EnumEncoders
  Else
    RaiseEvent Error(lError, GdiErrorString(lError))
  End If
End Sub

Private Sub Class_Terminate()
  If m_lToken Then GdiplusShutdown m_lToken
End Sub

Private Function EnumEncoders() As Long
  Dim lNumEncoders  As Long
  Dim lEncoderSize  As Long
  Dim lError        As Long
  Dim b()           As Byte
  Dim i             As Long
  Dim codecs()      As ImageCodecInfo
  
  lError = GdipGetImageEncodersSize(lNumEncoders, lEncoderSize)
  If Not lError Then
    ReDim codecs(lNumEncoders - 1)
    ReDim b(lEncoderSize - 1)
    
    lError = GdipGetImageEncoders(lNumEncoders, lEncoderSize, b(0))
    If Not lError Then
      RtlMoveMemory codecs(0), b(0), lNumEncoders * LenB(codecs(0))
      ReDim tGuids(lNumEncoders - 1)
      m_lNumCodecs = lNumEncoders
      Set colCodecs = Nothing
      Set colCodecs = New Collection
      
      Do While lNumEncoders
        lNumEncoders = lNumEncoders - 1
        tGuids(lNumEncoders) = codecs(lNumEncoders).CLSID
        ParseOnChar StringFromPointerW(codecs(lNumEncoders).pwszFilenameExtension), ";", lNumEncoders
      Loop
    Else
      RaiseEvent Error(lError, GdiErrorString(lError))
    End If
  Else
    RaiseEvent Error(lError, GdiErrorString(lError))
  End If
End Function

Private Sub ParseOnChar(ByRef sIn As String, ByRef sChar As String, ByVal lGuidIndex As Long)
  Dim lStartPosition As Long
  Dim lFoundPosition As Long
  Dim sItem          As String
  
  lFoundPosition = InStr(sIn, sChar)
  lStartPosition = 1
  
  Do While lFoundPosition
    sItem = Mid$(sIn, lStartPosition, lFoundPosition - lStartPosition)
    colCodecs.Add lGuidIndex, sItem
    lStartPosition = lFoundPosition + 1
    lFoundPosition = InStr(lStartPosition, sIn, sChar)
  Loop
  
  sItem = Trim$(Mid$(sIn, lStartPosition))
  If LenB(sItem) Then colCodecs.Add lGuidIndex, sItem
End Sub

Private Function ExtensionExists(ByRef sKey As String) As Long
  On Error GoTo errorhandler
  ExtensionExists = True
  
  If Not colCodecs Is Nothing Then
    ExtensionExists = colCodecs.Item(sKey)
  End If
  
  Exit Function
errorhandler:

End Function

Private Function StringToGuid(ByRef sGuid As String) As CLSID
  CLSIDFromString sGuid, StringToGuid
End Function

Public Function PictureBoxToFile(ByVal pic As PictureBox, ByRef sFilename As String, Optional lQuality As Long = 85) As Long
  Dim sExtension As String
  Dim bitmap     As Long
  Dim lError     As Long
  Dim params     As EncoderParameters
  Dim lQual      As Long
  Dim lIndex     As Long
  Dim tguid      As CLSID
  
  sExtension = GetExtension(sFilename)
  
  lIndex = ExtensionExists("*." & sExtension)
  If lIndex > -1 Then
    lError = GdipCreateBitmapFromHBITMAP(pic.Picture.Handle, pic.Picture.hPal, bitmap)
    If Not lError Then
      If (Asc(sExtension) And Not 32) = vbKeyJ Then
        lQual = lQuality
        params.Count = 1
        params.Parameter.CLSID = StringToGuid(EncoderQuality)
        params.Parameter.NumberOfValues = 1
        params.Parameter.Type = EncoderParameterValueTypeLong
        params.Parameter.Value = VarPtr(lQual)
        lError = GdipSaveImageToFile(bitmap, sFilename, tGuids(lIndex), params)
      Else
        lError = GdipSaveImageToFile(bitmap, sFilename, tGuids(lIndex), ByVal 0)
      End If
      
      If Not lError Then
        GdipDisposeImage bitmap
        PictureBoxToFile = True
      Else
        RaiseEvent Error(lError, GdiErrorString(lError))
      End If
    Else
      RaiseEvent Error(lError, GdiErrorString(lError))
    End If
  End If
End Function

Private Function GetExtension(ByRef sFile As String) As String
  Dim iPos      As Long
  Dim iPosPrev  As Long
  
  Do
    iPosPrev = iPos
    iPos = InStr(iPos + 1, sFile, ".")
  Loop While iPos
  
  If iPosPrev Then
    If InStr(iPosPrev + 1, sFile, "\") = 0 Then
      GetExtension = Mid$(sFile, iPosPrev + 1)
    End If
  End If
End Function

Private Function StringFromPointerW(ByVal lPointer As Long) As String
  Dim lLength As Long
  
  If lPointer Then
    lLength = lstrlenW(lPointer)
    StringFromPointerW = Space$(lLength)
    RtlMoveMemory ByVal StrPtr(StringFromPointerW), ByVal lPointer, lLength * 2
  End If
End Function

Public Function GdiErrorString(ByVal lError As Status) As String
  Dim s As String
  
  Select Case lError
    Case GenericError:              s = "Generic Error"
    Case InvalidParameter:          s = "Invalid Parameter"
    Case OutOfMemory:               s = "Out Of Memory"
    Case ObjectBusy:                s = "Object Busy"
    Case InsufficientBuffer:        s = "Insufficient Buffer"
    Case NotImplemented:            s = "Not Implemented"
    Case Win32Error:                s = "Win32 Error"
    Case WrongState:                s = "Wrong State"
    Case Aborted:                   s = "Aborted"
    Case FileNotFound:              s = "File Not Found"
    Case ValueOverflow:             s = "Value Overflow"
    Case AccessDenied:              s = "Access Denied"
    Case UnknownImageFormat:        s = "Unknown Image Format"
    Case FontFamilyNotFound:        s = "FontFamily Not Found"
    Case FontStyleNotFound:         s = "FontStyle Not Found"
    Case NotTrueTypeFont:           s = "Not TrueType Font"
    Case UnsupportedGdiplusVersion: s = "Unsupported Gdiplus Version"
    Case GdiplusNotInitialized:     s = "Gdiplus Not Initialized"
    Case PropertyNotFound:          s = "Property Not Found"
    Case PropertyNotSupported:      s = "Property Not Supported"
    Case Else:                      s = "Unknown GDI+ Error"
  End Select
  
  GdiErrorString = s
End Function

