Attribute VB_Name = "z_LoadPictureAPI"
'================ Модуль загрузки изображения через GDI =============
' Shared module version: 20210228
' Required reference:
Option Private Module
Option Explicit

'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

'Declare a UDT to store the bitmap information
Private Type PictDescriptor
  size_ As LongLong
  type_ As LongLong
  hPic_ As LongPtr
  hPal_ As LongLong
End Type

'Declare a UDT to store the GDI+ Startup information
Private Type GdiplusStartupInput
  version_ As Long
  callback_ As LongPtr
  suppBgThread_ As LongLong
  suppExtCodecs_ As LongLong
End Type

'Windows API calls into the GDI+ library
Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (pToken As LongPtr, pInputBuf As GdiplusStartupInput, Optional ByVal pOutputBuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal pFile As LongPtr, pBitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal pBitmap As LongPtr, hbmReturn As LongPtr, ByVal pBackground As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal pImage As LongPtr) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal pToken As LongPtr) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PictDescriptor, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, iPic As IPicture) As LongPtr

Private Const PICTYPE_BITMAP = 1

' Procedure:  LoadPictureGDI
' Purpose:    Loads an image using GDI+
' Returns:    The image as an IPicture Object
Public Function LoadPictureGDI(ByVal sFileName$) As IPicture
  'Initialize GDI+
  Dim uGdiInput As GdiplusStartupInput
  uGdiInput.version_ = 1
  Dim hGdiPlus As LongPtr
  Dim lResult&: lResult = GdiplusStartup(hGdiPlus, uGdiInput)

  If lResult <> 0 Then _
    Exit Function
  
  Dim hGdiImage As LongPtr
  If GdipCreateBitmapFromFile(StrPtr(sFileName), hGdiImage) = 0 Then
    Dim hBitmap As LongPtr
    Call GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0)
    Set LoadPictureGDI = CreateIPicture(hBitmap)
    Call GdipDisposeImage(hGdiImage)
  End If
  
  Call GdiplusShutdown(hGdiPlus)
End Function

' Procedure:  CreateIPicture
' Purpose:    Converts a image handle into an IPicture object.
' Returns:    The IPicture object
Private Function CreateIPicture(ByVal hPic As LongPtr) As IPicture
  Dim IID_IDispatch As GUID
  With IID_IDispatch
    .Data1 = &H7BF80980
    .Data2 = &HBF32
    .Data3 = &H101A
    .Data4(0) = &H8B
    .Data4(1) = &HBB
    .Data4(2) = &H0
    .Data4(3) = &HAA
    .Data4(4) = &H0
    .Data4(5) = &H30
    .Data4(6) = &HC
    .Data4(7) = &HAB
  End With
  
  Dim uPicInfo As PictDescriptor
  With uPicInfo
    .size_ = Len(uPicInfo)
    .type_ = PICTYPE_BITMAP
    .hPic_ = hPic
    .hPal_ = 0
  End With

  Dim iPic As IPicture
  Call OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, iPic)
  Set CreateIPicture = iPic
End Function