Attribute VB_Name = "ModGDIPlus"
' ModGDIPlus.bas

' Original GDI+ for VB6 by Avery PSC CodeId=37541.

' Reconstructed from PSC CodeId=70008 by Ed Wilk "Save As PNG, GIF, TIF"
' and CodeId=48352 by Miltiadis Kritokos "Load and Resize Pictures with GDI+"

Option Explicit

Public aHasGDI As Boolean

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

Private Type PICTDESC
   size     As Long
   Type     As Long
   hBmp     As Long
   hpal     As Long
   Reserved As Long
End Type

Private Type GDIPlusStartupInput
    GdiPlusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type

Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long


Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, lpWideCharStr As Any, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long

' GDI Functions
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) 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 GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

' GDI+ functions
Private Declare Sub GdiplusStartup Lib "gdiplus.dll" (token As Long, gdipInput As GDIPlusStartupInput, GdiplusStartupOutput As Long)

Private Declare Function GdipLoadImageFromFile Lib "gdiplus.dll" (ByVal FileName As Long, GpImage As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus.dll" (ByVal hDC As Long, GpGraphics As Long) As Long
Private Declare Function GdipDrawImageRectI Lib "gdiplus.dll" (ByVal Graphics As Long, ByVal img As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus.dll" (ByVal Graphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus.dll" (ByVal Image As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" (ByVal hBmp As Long, ByVal hpal As Long, GpBitmap As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus.dll" (ByVal Image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus.dll" (ByVal Image As Long, Height As Long) As Long
'Private Declare Function GdipDrawImageRectRectI Lib "gdiplus.dll" (ByVal Graphics As Long, ByVal GpImage As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal callback As Long, ByVal callbackData As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal FileName As Long, ByRef clsidEncoder As GUID, ByRef encoderParams As Any) As Long
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (ByRef numEncoders As Long, ByRef size As Long) As Long
Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal size As Long, ByRef Encoders As Any) As Long

Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)

' GDI and GDI+ constants
Private Const PLANES = 14            '  Number of planes
Private Const BITSPIXEL = 12         '  Number of bits per pixel
Private Const PATCOPY = &HF00021     ' (DWORD) dest = pattern
Private Const PICTYPE_BITMAP = 1     ' Bitmap type
Private Const CP_ACP            As Long = 0

Private Type ImageCodecInfo
   ClassID As GUID
   FormatID As GUID
   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

' Initialises GDI Plus
Public Function initGDIPlus() As Long
Dim token    As Long
Dim gdipInit As GDIPlusStartupInput
   gdipInit.GdiPlusVersion = 1
   GdiplusStartup token, gdipInit, ByVal 0&
   initGDIPlus = token
End Function

' Frees GDI Plus
Public Sub FreeGDIPlus(token As Long)
   GdiplusShutdown token
End Sub

Public Function LoadPictureGDIPlus(PicFile As String, Optional ByVal BackColor As Long = vbWhite) As IPicture
Dim hDC     As Long
Dim hBitmap As Long
Dim img     As Long
Dim IWidth As Long
Dim IHeight As Long
Dim Graphics As Long   ' Graphics Object Pointer
   ' Load the image
'   GdipLoadImageFromFile StrPtr(PicFile), img
   ' NB will not load 24bpp icons in IDE  Ok in EXE
   
   If GdipLoadImageFromFile(StrPtr(PicFile), img) <> 0 Then
       'Err.Raise 999, "GDIPlus Module", "Error opening " & PicFile
       MsgBox "GDIPlus error!", vbCritical, "LoadPictureGDIPlus"
       Exit Function
   End If
   
   GdipGetImageWidth img, IWidth
   GdipGetImageHeight img, IHeight
   ' Initialise the hDC
   InitDC hDC, hBitmap, BackColor, IWidth, IHeight
   
   GdipCreateFromHDC hDC, Graphics
   GdipDrawImageRectI Graphics, img, 0, 0, IWidth, IHeight
   GdipDeleteGraphics Graphics
   
   GdipDisposeImage img
   ' Get the bitmap back
   GetBitmap hDC, hBitmap
   ' Create the picture
   Set LoadPictureGDIPlus = CreatePicture(hBitmap)
End Function

' Initialises the hDC to draw
Private Sub InitDC(hDC As Long, hBitmap As Long, BackColor As Long, Width As Long, Height As Long)
Dim hBrush As Long
   ' Create a memory DC and select a bitmap into it, fill it in with the backcolor
   hDC = CreateCompatibleDC(ByVal 0&)
   hBitmap = CreateBitmap(Width, Height, GetDeviceCaps(hDC, PLANES), GetDeviceCaps(hDC, BITSPIXEL), ByVal 0&)
   hBitmap = SelectObject(hDC, hBitmap)
   hBrush = CreateSolidBrush(BackColor)
   hBrush = SelectObject(hDC, hBrush)
   PatBlt hDC, 0, 0, Width, Height, PATCOPY
   DeleteObject SelectObject(hDC, hBrush)
End Sub

' Replaces the old bitmap of the hDC, Returns the bitmap and Deletes the hDC
Private Sub GetBitmap(hDC As Long, hBitmap As Long)
   hBitmap = SelectObject(hDC, hBitmap)
   DeleteDC hDC
End Sub

' Creates a Picture Object from a handle to a bitmap
Private Function CreatePicture(hBitmap As Long) As IPicture
Dim IID_IDispatch As GUID
Dim PIC           As PICTDESC
Dim IPic          As IPicture
   ' Fill in OLE IDispatch Interface ID
   IID_IDispatch.Data1 = &H20400
   IID_IDispatch.Data4(0) = &HC0
   IID_IDispatch.Data4(7) = &H46
       
   ' Fill Pic with necessary parts
   PIC.size = Len(PIC)        ' Length of structure
   PIC.Type = PICTYPE_BITMAP  ' Type of Picture (bitmap)
   PIC.hBmp = hBitmap         ' Handle to bitmap
   
   ' Create the picture
   OleCreatePictureIndirect PIC, IID_IDispatch, True, IPic
   Set CreatePicture = IPic
End Function

Public Function SavePictureFromHDC(ByVal hBitmap As Long, ByVal sFileName As String) As Boolean
Dim lBitmap As Long
Dim PicEncoder As GUID
Dim sID As String
   ' Use file name extention to determine,
   ' what format we want to save the file in.
   Select Case LCase$(Right$(sFileName, 4))
      Case ".png"
         sID = "image/png"
      Case ".gif"
         sID = "image/gif"
      Case ".jpg"
         sID = "image/jpeg"
      Case ".tif"
         sID = "image/tiff"
      Case ".bmp"
         sID = "image/bmp"
      Case Else
         Exit Function
   End Select
   
   If GdipCreateBitmapFromHBITMAP(hBitmap, 0&, lBitmap) = 0 Then
      If GetEncoderClsid(sID, PicEncoder) = True Then
          SavePictureFromHDC = (GdipSaveImageToFile(lBitmap, StrPtr(sFileName), PicEncoder, ByVal 0) = 0)
      End If
      GdipDisposeImage lBitmap
   Else
      SavePictureFromHDC = False
      Err.Raise 999, "GDIPlus Module", "Error saving " & sFileName
   End If
End Function

Private Function GetEncoderClsid(strMimeType As String, ClassID As GUID) As Boolean
Dim num As Long
Dim size As Long
Dim imgCodecInfo() As ImageCodecInfo
Dim lval As Long
Dim Buffer() As Byte
   GdipGetImageEncodersSize num, size
   If size Then
      ReDim imgCodecInfo(num) As ImageCodecInfo
      ReDim Buffer(size) As Byte
      
      GdipGetImageEncoders num, size, Buffer(0)
      CopyMemory imgCodecInfo(0), Buffer(0), (Len(imgCodecInfo(0)) * num)
      
      For lval = 0 To num - 1
         'image/bmp,image/jpeg,image/gif,image/tiff,image/png
         If StrComp(GetStrFromPtrW(imgCodecInfo(lval).MimeType), strMimeType, vbTextCompare) = 0 Then
             ClassID = imgCodecInfo(lval).ClassID
             GetEncoderClsid = True
             Exit For
         End If
      Next
      Erase imgCodecInfo
      Erase Buffer
   End If
End Function

Private Function GetStrFromPtrW(lpszW As Long) As String
Dim sRV As String
   sRV = String$(lstrlenW(ByVal lpszW) * 2, vbNullChar)
   WideCharToMultiByte CP_ACP, 0, ByVal lpszW, -1, ByVal sRV, Len(sRV), 0, 0
   GetStrFromPtrW = Left$(sRV, lstrlenW(StrPtr(sRV)))
End Function
