Attribute VB_Name = "modEnumResIcons"
' -------------------------------------------------------------------------------
'
'   AVStoDVD - by MrC
'   File: modEnumResIcons.bas
'   Purpose: Load resources ICON from a EXE/DLL library
'   Thanks to: Giorgio Brausi (vbcorner@vbcorner.net - http://www.vbcorner.net)
'              who developed most of following code (03/04/2004)
'
' -------------------------------------------------------------------------------


Option Explicit
Option Compare Binary
Option Base 0


Private IconsIL As ImageList
Private ghmodule As Long
Private giSize As Integer
Private giColorDepth As Integer
Private arrSize As Long

Private arIcon(1 To 4, 1 To 4)
Private Const SIZE_16 = 1
Private Const SIZE_24 = 2
Private Const SIZE_32 = 3
Private Const SIZE_48 = 4
Private Const COLOR_4 = 1
Private Const COLOR_8 = 2
Private Const COLOR_24 = 3
Private Const COLOR_32 = 4
Private Const DIFFERENCE = 11
Private Const LR_LOADMAP3DCOLORS As Long = &H1000
Private Const DONT_RESOLVE_DLL_REFERENCES = &H1

Public Enum ResType ' Resource Types
    RT_FIRST = 1&
    RT_CURSOR = 1&
    RT_BITMAP = 2&
    RT_ICON = 3&
    RT_MENU = 4&
    RT_DIALOG = 5&
    RT_STRING = 6&
    RT_FONTDIR = 7&
    RT_FONT = 8&
    RT_ACCELERATOR = 9&
    RT_RCDATA = 10&
    RT_MESSAGETABLE = (11)
    RT_GROUP_CURSOR = (RT_CURSOR + DIFFERENCE)  ' (12)
    RT_GROUP_ICON = (RT_ICON + DIFFERENCE)      ' (14)
    RT_VERSION = (16)
    'RT_DLGINCLUDE = (17)
    'RT_PLUGPLAY = (19)
    'RT_VXD = (20)
    'RT_ANICURSOR = (21)
    'RT_ANIICON = (22)
    'RT_HTML = (23)
    RT_LAST = (16)
End Enum

Private Type PictDesc
    cbSizeofStruct As Long
    PicType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function EnumResourceNames Lib "kernel32" Alias "EnumResourceNamesA" (ByVal ghmodule As Long, ByVal lpType As ResType, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function StrLen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Function StrCpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Private Declare Function FindResource Lib "kernel32.dll" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As String, ByVal lpType As String) As Long
Private Declare Function FindResourceByNum Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As String, ByVal lpType As Long) As Long
Private Declare Function LoadResource Lib "kernel32.dll" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function CreateIconFromResourceEx Lib "user32" (presbits As Byte, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal uFlags As Long) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)


Public Function GetPictureRes(ByVal sResType As String, ByVal sResName As String, ByVal iSize As Integer, ByVal iColorDepth As Integer) As StdPicture

    Dim hData As Long
    Dim arr() As Byte
    Dim vRet As Variant
    
    Select Case sResType
    Case "1", "3" ' Hardware dependent cursor or icon.
        vRet = GetDataArray(sResType, sResName, iSize, iColorDepth)
        If CStr(vRet) = "0" Then
            Set GetPictureRes = Nothing
            Exit Function
        Else
            arr = vRet
            hData = CreateIconFromResourceEx(arr(0), UBound(arr) + 1, CLng(sResType) - 1, &H30000, 0, 0, LR_LOADMAP3DCOLORS)
        End If
    Case "2"  ' Bitmap
        hData = LoadImage(ghmodule, sResName, 0, 0, 0, LR_LOADMAP3DCOLORS)
    Case "12" ' Hardware independent cursor
        hData = LoadImage(ghmodule, sResName, 2, 0, 0, LR_LOADMAP3DCOLORS)
    Case "14" ' Hardware independent icon
        hData = LoadImage(ghmodule, sResName, 1, 0, 0, LR_LOADMAP3DCOLORS)
    End Select
    If hData = 0 Then Exit Function
    
    Set GetPictureRes = IconToPicture(hData)
    
End Function

' Export the resource from ICON to PICTURE
Private Function IconToPicture(ByVal hIcon As Long) As StdPicture
    
    Dim oNewPic As Picture
    Dim tPicConv As PictDesc
    Dim IGuid As GUID
    
    If hIcon = 0 Then Exit Function
    With tPicConv
        .cbSizeofStruct = Len(tPicConv)
        .PicType = vbPicTypeIcon
        .hImage = hIcon
    End With
    With IGuid
        .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
    OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
    Set IconToPicture = oNewPic

End Function

Public Function GetDataArray(ByVal ResType As String, ByVal ResName As String, ByVal iSize As Integer, ByVal iColorDepth As Integer) As Variant
    
    Dim hRsrc As Long
    Dim hGlobal As Long
    Dim arrData() As Byte
    Dim lpData As Long
    Dim iNDXSize As Integer
    Dim iNDXColor As Integer
    
    If IsNumeric(ResType) Then hRsrc = FindResourceByNum(ghmodule, ResName, CLng(ResType))
    If hRsrc = 0 Then hRsrc = FindResource(ghmodule, ResName, ResType)
    If hRsrc = 0 Then Exit Function
    hGlobal = LoadResource(ghmodule, hRsrc)
    lpData = LockResource(hGlobal)
    
    arrSize = SizeofResource(ghmodule, hRsrc)
    Select Case iSize
    Case 16
        iNDXSize = 1
    Case 24
        iNDXSize = 2
    Case 32
        iNDXSize = 3
    Case 48
        iNDXSize = 4
    End Select
    Select Case iColorDepth
    Case 4
        iNDXColor = 1
    Case 16
        iNDXColor = 2
    Case 24
        iNDXColor = 3
    Case 32
        iNDXColor = 4
    End Select
    
    If arrSize = 0 Then
        GetDataArray = 0
        Exit Function
    End If
    
    ReDim arrData(arrSize - 1)
    Call CopyMemory(arrData(0), ByVal lpData, arrSize)
    Call FreeResource(hGlobal)
    GetDataArray = arrData

End Function

Public Function EnumResNameProc(ByVal ghmodule As Long, ByVal lpszType As ResType, ByVal lpszName As Long, ByVal lParam As Long) As Long
    
    Dim sNumber As String
    Dim IsNum As Boolean
    
    If (lpszName > &HFFFF&) Or (lpszName < 0) Then
        sNumber = PtrToVBString(lpszName)
        IsNum = False
    Else
        sNumber = CStr(lpszName)
        IsNum = True
    End If
    
    ' 16x16
    arIcon(SIZE_16, COLOR_4) = 296
    arIcon(SIZE_16, COLOR_8) = 1384
    arIcon(SIZE_16, COLOR_24) = 872
    arIcon(SIZE_16, COLOR_32) = 1128
    ' 24x24
    arIcon(SIZE_24, COLOR_4) = 488
    arIcon(SIZE_24, COLOR_8) = 1736
    arIcon(SIZE_24, COLOR_24) = 1864
    arIcon(SIZE_24, COLOR_32) = 2440
    ' 32x32
    arIcon(SIZE_32, COLOR_4) = 744
    arIcon(SIZE_32, COLOR_8) = 2216
    arIcon(SIZE_32, COLOR_24) = 3240
    arIcon(SIZE_32, COLOR_32) = 4264
    ' 48x48
    arIcon(SIZE_48, COLOR_4) = 1640
    arIcon(SIZE_48, COLOR_8) = 3752
    arIcon(SIZE_48, COLOR_24) = 7336
    arIcon(SIZE_48, COLOR_32) = 9640
    
    If IsNum Then
        If lpszType = RT_ICON Then
            LoadIconRes lpszType, sNumber, giSize, giColorDepth
        End If
    End If
    EnumResNameProc = 1

End Function

Private Function PtrToVBString(ByVal lpszBuffer As Long) As String
    
    Dim Buffer As String
    Dim LenBuffer As Long
    
    LenBuffer = StrLen(lpszBuffer)
    Buffer = String(LenBuffer + 1, 0)
    StrCpy Buffer, lpszBuffer
    PtrToVBString = Left(Buffer, LenBuffer)

End Function

Public Sub LoadIconRes(ByVal sResType As ResType, ByVal sResNumber As String, ByVal iSize As Integer, ByVal iColorDepth As Integer)
    
    Dim sResName As String
    Dim hPicture As StdPicture
    Dim h As Long
    Dim w As Long
    Dim bAddIcon As Boolean
    
    sResName = sResNumber
    If IsNumeric(sResName) Then sResName = "#" & sResName
    
    ' load the icon that match the Size (lSize)
    Set hPicture = GetPictureRes(sResType, sResName, iSize, iColorDepth)
    w = Round(hPicture.Width / 26.45, 0)
    h = Round(hPicture.Height / 26.45, 0)
    
    If Not hPicture Is Nothing Then
        If iSize = 0 Then
            bAddIcon = True
        Else
            If iSize = w And iSize = h Then
                bAddIcon = True
            End If
        End If
        If bAddIcon = True Then
            IconsIL.ListImages.add , sResName & " " & CStr(arrSize) & " " & w & "x" & h, hPicture
            
            ' I want know other images size and color depth
            Select Case arrSize
                Case 1640, 744, 488, 296, 3752, 2216, 1736, 1384, 9640, 4264, 2440, 1128, 7336, 3240, 1864, 872
                    ' This is image formats already knows
                Case Else
                    ' There is many image formats: monochrome, 21x24, ...
                    ' List2 enumerate all formats 'not request' by me.
                    ' So we can see what and which image contains the library
                    ' msgbox Format(sResName, "@@@@@") & " " & _
                                             Format(arrSize, "@@@@@") & " " & _
                                             w & "x" & h
            End Select
        End If
    End If
    
End Sub

' Get all icons from library, fill the IconsImageList with images
Public Sub GetIconsFromLibrary(ByVal sLibraryFilePath As String, IconsImageList As ImageList, Optional IconsSize As Integer)
    
    Dim tRes As ResType
    
    Set IconsIL = IconsImageList
    giSize = IconsSize
    ghmodule = LoadLibraryEx(sLibraryFilePath, 0, DONT_RESOLVE_DLL_REFERENCES)
    If ghmodule = 0 Then
        MsgBox "Warning! Invalid library file.", vbCritical, App.Title
        Exit Sub
    End If
    
    ' clear objects
    IconsIL.ListImages.Clear
    
    ' libraries with many icons require a lot of time
    Screen.MousePointer = vbHourglass
    For tRes = RT_FIRST To RT_LAST
        DoEvents
        EnumResourceNames ghmodule, tRes, AddressOf EnumResNameProc, 0
    Next
    FreeLibrary ghmodule
    Screen.MousePointer = vbNormal
    
End Sub
