[RESOLVED] Upload PNG images into native Windows image list or vbAccelerator ImageList

[fafalone]

Regular transparency in PNGs works fine in XP.. can you post a blended one to test?

----------------
IExtractImage for PNG does work in XP, I just finished writing an XP-compatible version :::shudder:::

With oleexp.tlb and mIID.bas, the following is a complete example:

Public Function GetFileThumbnailXP(sPath As String, sFile As String, cx As Long, cy As Long) As Long
Debug.Print "Called GetFileThumbnailXP(" & sPath & ", " & sFile & ", " & cx & ", " & cy & ")"
Dim isf As oleexp.IShellFolder

Dim pidl As Long
Dim pidlPar As Long
Dim pidlFQ As Long
Dim iei As oleexp.IExtractImage
Dim hBmp As Long
Dim uThumbSize As oleexp.SIZE
    uThumbSize.cx = cx
    uThumbSize.cy = cy
Dim sRet As String
Dim uThumbFlags As IEIFlags

On Error GoTo e0
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

pidlFQ = ILCreateFromPathW(StrPtr(sPath & sFile))
If pidlFQ = 0 Then
    Debug.Print "GetFileThumbnailXP::Failed to get fully qualified pidl"
    GoTo clnup
End If

pidlPar = ILCreateFromPathW(StrPtr(sPath))
If pidlPar = 0 Then
    Debug.Print "GetFileThumbnailXP::Failed to get parent pidl"
    GoTo clnup
End If

isfDesktop.BindToObject pidlPar, 0&, IID_IShellFolder, isf
If (isf Is Nothing) Then
    Debug.Print "GetFileThumbnailXP::Failed to get parent IShellFolder"
    GoTo clnup
End If

pidl = ILFindLastID(pidlFQ)
If pidl = 0 Then
    Debug.Print "GetFileThumbnailXP::Failed to get relative pidl"
    GoTo clnup
End If

isf.GetUIObjectOf 0&, 1&, pidl, IID_IExtractImage, 0&, iei
If (iei Is Nothing) Then
    Debug.Print "GetFileThumbnailXP::Failed to create IExtractImage"
    GoTo clnup
End If

uThumbFlags = IEIFLAG_ASPECT
sRet = String$(MAX_PATH, 0)
iei.GetLocation StrPtr(sRet), MAX_PATH, 0&, uThumbSize, 32, uThumbFlags
Debug.Print "GetFileThumbnailXP::GetLocation OK, sret=" & sRet

hBmp = iei.Extract()

GetFileThumbnailXP = hBmp
If hBmp = 0 Then
    Debug.Print "GetFileThumbnailXP::Failed to get HBITMAP"
End If
clnup:
Set iei = Nothing
Call CoTaskMemFree(pidlFQ)
Call CoTaskMemFree(pidlPar)
'do NOT call free on pidl (the child-only pidl)
Set isf = Nothing

On Error GoTo 0
Exit Function

e0:
Debug.Print "GetFileThumbnailXP::Error->" & Err.Description & " (" & Err.Number & ")"
End Function

Then the HBITMAP from that is added into an ImageList and drawn (with transparency) onto a picturebox with:

Public Sub hBitmapToPictureBox(picturebox As Object, hBitmap As Long, Optional x As Long = 0&, Optional y As Long = 0&)
Dim himlBmp As Long
Dim tBMP As BITMAP
Dim cx As Long, cy As Long
Call GetObject(hBitmap, LenB(tBMP), tBMP)
cx = tBMP.BMWidth
cy = tBMP.BMHeight
If cx = 0 Then
    Debug.Print "Invalid image"
    Exit Sub
End If
himlBmp = ImageList_Create(cx, cy, ILC_COLOR32, 1, 1)

ImageList_Add himlBmp, hBitmap, 0&
ImageList_Draw himlBmp, 0, picturebox.hDC, x, y, ILD_NORMAL

ImageList_Destroy himlBmp
End Sub

APIs and other support for the above code:

Public Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long ' Retrieves the IShellFolder interface for the desktop folder.
Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Function ILFindLastID Lib "shell32" (ByVal pidl As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Type BITMAP
    BMType As Long
    BMWidth As Long
    BMHeight As Long
    BMWidthBytes As Long
    BMPlanes As Integer
    BMBitsPixel As Integer
    BMBits As Long
End Type
Public Declare Function ImageList_Create Lib "comctl32" (ByVal MinCx As Long, ByVal MinCy As Long, ByVal flags As Long, ByVal cInitial As Long, ByVal cGrow As Long) As Long
Public Declare Function ImageList_Add Lib "comctl32" (ByVal hImageList As Long, ByVal hBitmap As Long, ByVal hBitmapMask As Long) As Long
Public Declare Function ImageList_Draw Lib "comctl32.dll" (ByVal himl As Long, ByVal i As Long, ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, ByVal fStyle As IL_DrawStyle) As Boolean
Public Declare Function ImageList_Destroy Lib "comctl32" (ByVal hImageList As Long) As Long
Public Enum IL_DrawStyle
  ILD_NORMAL = &H0
  ILD_TRANSPARENT = &H1
  ILD_MASK = &H10
  ILD_IMAGE = &H20
'#If (WIN32_IE >= &H300) Then
  ILD_ROP = &H40
'#End If
  ILD_BLEND25 = &H2
  ILD_BLEND50 = &H4
  ILD_OVERLAYMASK = &HF00
 
  ILD_SELECTED = ILD_BLEND50
  ILD_FOCUS = ILD_BLEND25
  ILD_BLEND = ILD_BLEND50
End Enum
Public Enum IL_CreateFlags
  ILC_MASK = &H1
  ILC_COLOR = &H0
  ILC_COLORDDB = &HFE
  ILC_COLOR4 = &H4
  ILC_COLOR8 = &H8
  ILC_COLOR16 = &H10
  ILC_COLOR24 = &H18
  ILC_COLOR32 = &H20
  ILC_PALETTE = &H800                  ' (no longer supported...never worked anyway)
  '5.0
  ILC_MIRROR = &H2000
  ILC_PERITEMMIRROR = &H8000
  '6.0
  ILC_ORIGINALSIZE = &H10000
  ILC_HIGHQUALITYSCALE = &H20000
End Enum

Public Function isfDesktop() As IShellFolder
  Static isf As IShellFolder
  If (isf Is Nothing) Then Call SHGetDesktopFolder(isf)
  Set isfDesktop = isf
End Function

And finally called as (note: picturebox must have autoredraw=true)

    Dim hb As Long
    hb = GetFileThumbnailXP("C:\temp2\png\", "256.png", 32, 32)
    hBitmapToPictureBox Picture1, hb
    Picture1.Refresh

Tested to work on a stock install of XP SP3