vbAccelerator - Contents of code file: cVBALImageList.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cVBALImageList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' =========================================================================
' vbAccelerator Image List Control Demonstrator
' Copyright  1998 Steve McMahon (steve@dogma.demon.co.uk)
'
' Implements an Image List control in VB using COMCTL32.DLL
'
' Visit vbAccelerator at http://vbaccelerator.com/
' =========================================================================

' -----------
' API
' -----------
' General:
Private Declare Function GetWindowWord Lib "user32" (ByVal hwnd As Long, ByVal
 nIndex As Long) As Integer
    Private Const GWW_HINSTANCE = (-6)
    
' GDI object functions:
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As
 Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal
 hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc
 As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) 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 Const BITSPIXEL = 12
    Private Const LOGPIXELSX = 88    '  Logical pixels/inch in X
    Private Const LOGPIXELSY = 90    '  Logical pixels/inch in Y
' System metrics:
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long)
 As Long
    Private Const SM_CXICON = 11
    Private Const SM_CYICON = 12
    Private Const SM_CXFRAME = 32
    Private Const SM_CYCAPTION = 4
    Private Const SM_CYFRAME = 33
    Private Const SM_CYBORDER = 6
    Private Const SM_CXBORDER = 5

' Region paint and fill functions:
Private Declare Function PaintRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As
 Long) As Long
Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal x
 As Long, ByVal y As Long, ByVal crColor As Long, ByVal wFillType As Long) As
 Long
    Private Const FLOODFILLBORDER = 0
    Private Const FLOODFILLSURFACE = 1
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long) As Long

' Pen functions:
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
    Private Const PS_DASH = 1
    Private Const PS_DASHDOT = 3
    Private Const PS_DASHDOTDOT = 4
    Private Const PS_DOT = 2
    Private Const PS_SOLID = 0
    Private Const PS_NULL = 5

' Brush functions:
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long)
 As Long

' Line functions:
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long) As Long
Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long

' Colour functions:
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal
 nBkMode As Long) As Long
    Private Const OPAQUE = 2
    Private Const TRANSPARENT = 1
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Const COLOR_ACTIVEBORDER = 10
    Private Const COLOR_ACTIVECAPTION = 2
    Private Const COLOR_ADJ_MAX = 100
    Private Const COLOR_ADJ_MIN = -100
    Private Const COLOR_APPWORKSPACE = 12
    Private Const COLOR_BACKGROUND = 1
    Private Const COLOR_BTNFACE = 15
    Private Const COLOR_BTNHIGHLIGHT = 20
    Private Const COLOR_BTNSHADOW = 16
    Private Const COLOR_BTNTEXT = 18
    Private Const COLOR_CAPTIONTEXT = 9
    Private Const COLOR_GRAYTEXT = 17
    Private Const COLOR_HIGHLIGHT = 13
    Private Const COLOR_HIGHLIGHTTEXT = 14
    Private Const COLOR_INACTIVEBORDER = 11
    Private Const COLOR_INACTIVECAPTION = 3
    Private Const COLOR_INACTIVECAPTIONTEXT = 19
    Private Const COLOR_MENU = 4
    Private Const COLOR_MENUTEXT = 7
    Private Const COLOR_SCROLLBAR = 0
    Private Const COLOR_WINDOW = 5
    Private Const COLOR_WINDOWFRAME = 6
    Private Const COLOR_WINDOWTEXT = 8
    Private Const COLORONCOLOR = 3

' Shell Extract icon functions:
Private Declare Function FindExecutable Lib "shell32.dll" Alias
 "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal
 lpResult As String) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA"
 (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As
 Long) As Long

' Icon functions:
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal
 xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long,
 ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw
 As Long, ByVal diFlags As Long) As Boolean
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst
 As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2
 As Long, ByVal un2 As Long) As Long
Private Declare Function LoadImageLong Lib "user32" Alias "LoadImageA" (ByVal
 hInst As Long, ByVal lpsz As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal
 n2 As Long, ByVal un2 As Long) As Long
    Private Const LR_LOADMAP3DCOLORS = &H1000
    Private Const LR_LOADFROMFILE = &H10
    Private Const LR_LOADTRANSPARENT = &H20
    Private Const LR_COPYRETURNORG = &H4

' Blitting functions
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As
 Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
 hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
 As Long
    Private Const SRCAND = &H8800C6
    Private Const SRCCOPY = &HCC0020
    Private Const SRCERASE = &H440328
    Private Const SRCINVERT = &H660046
    Private Const SRCPAINT = &HEE0086
    Private Const BLACKNESS = &H42
    Private Const WHITENESS = &HFF0062
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 LoadBitmapBynum Lib "user32" Alias "LoadBitmapA"
 (ByVal hInstance As Long, ByVal lpBitmapName As Long) As Long
Private Type BITMAP '14 bytes
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As BITMAP)
 As Long

' Text functions:
Private Type RECT
    left As Long
    tOp As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptX As
 Long, ByVal ptY As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As
 Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal
 wFormat As Long) As Long
    Private Const DT_BOTTOM = &H8&
    Private Const DT_CENTER = &H1&
    Private Const DT_LEFT = &H0&
    Private Const DT_CALCRECT = &H400&
    Private Const DT_WORDBREAK = &H10&
    Private Const DT_VCENTER = &H4&
    Private Const DT_TOP = &H0&
    Private Const DT_TABSTOP = &H80&
    Private Const DT_SINGLELINE = &H20&
    Private Const DT_RIGHT = &H2&
    Private Const DT_NOCLIP = &H100&
    Private Const DT_INTERNAL = &H1000&
    Private Const DT_EXTERNALLEADING = &H200&
    Private Const DT_EXPANDTABS = &H40&
    Private Const DT_CHARSTREAM = 4&
    Private Const DT_NOPREFIX = &H800&
Private Type DRAWTEXTPARAMS
    cbSize As Long
    iTabLength As Long
    iLeftMargin As Long
    iRightMargin As Long
    uiLengthDrawn As Long
End Type
Private Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hdc
 As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As
 Long, lpDrawTextParams As DRAWTEXTPARAMS) As Long
Private Declare Function DrawTextExAsNull Lib "user32" Alias "DrawTextExA"
 (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT,
 ByVal un As Long, ByVal lpDrawTextParams As Long) As Long
    Private Const DT_EDITCONTROL = &H2000&
    Private Const DT_PATH_ELLIPSIS = &H4000&
    Private Const DT_END_ELLIPSIS = &H8000&
    Private Const DT_MODIFYSTRING = &H10000
    Private Const DT_RTLREADING = &H20000
    Private Const DT_WORD_ELLIPSIS = &H40000

Private Type SIZEAPI
    cX As Long
    cY As Long
End Type
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias
 "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
 cbString As Long, lpSize As SIZEAPI) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As
 Long
    Private Const ANSI_FIXED_FONT = 11
    Private Const ANSI_VAR_FONT = 12
    Private Const SYSTEM_FONT = 13
    Private Const DEFAULT_GUI_FONT = 17 'win95 only
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As
 Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT,
 ByVal edge As Long, ByVal grfFlags As Long) As Long
    Private Const BF_LEFT = 1
    Private Const BF_TOP = 2
    Private Const BF_RIGHT = 4
    Private Const BF_BOTTOM = 8
    Private Const BF_RECT = BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM
    Private Const BF_MIDDLE = 2048
    Private Const BDR_SUNKENINNER = 8
    Private Const BDR_SUNKENOUTER = 2
    Private Const BDR_RAISEDOUTER = 1
    Private Const BDR_RAISEDINNER = 4

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal
 nCmdShow As Long) As Long
    Private Const SW_SHOWNOACTIVATE = 4

' Scrolling and region functions:
Private Declare Function ScrollDC Lib "user32" (ByVal hdc As Long, ByVal dx As
 Long, ByVal dy As Long, lprcScroll As RECT, lprcClip As RECT, ByVal hrgnUpdate
 As Long, lprcUpdate As RECT) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal
 hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal
 hRgn As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal y1
 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As
 Long
Private Declare Function CreatePolyPolygonRgn Lib "gdi32" (lpPoint As POINTAPI,
 lpPolyCounts As Long, ByVal nCount As Long, ByVal nPolyFillMode As Long) As
 Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI,
 ByVal nCount As Long, ByVal nPolyFillMode As Long)
Private Declare Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal
 hSavedDC As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal
 lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As
 Any) As Long

Private Const LF_FACESIZE = 32
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
 "CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal
 nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect
 As RECT) As Long

Private Declare Function DrawState Lib "user32" Alias "DrawStateA" _
    (ByVal hdc As Long, _
    ByVal hBrush As Long, _
    ByVal lpDrawStateProc As Long, _
    ByVal lParam As Long, _
    ByVal wParam As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal cX As Long, _
    ByVal cY As Long, _
    ByVal fuFlags As Long) As Long

'/* Image type */
Private Const DST_COMPLEX = &H0&
Private Const DST_TEXT = &H1&
Private Const DST_PREFIXTEXT = &H2&
Private Const DST_ICON = &H3&
Private Const DST_BITMAP = &H4&

' /* State type */
Private Const DSS_NORMAL = &H0&
Private Const DSS_UNION = &H10& ' Dither
Private Const DSS_DISABLED = &H20&
Private Const DSS_MONO = &H80& ' Draw in colour of brush specified in hBrush
Private Const DSS_RIGHT = &H8000&

Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1

' Image list functions:
Private Declare Function ImageList_GetBkColor Lib "COMCTL32" (ByVal hImageList
 As Long) As Long
Private Declare Function ImageList_ReplaceIcon Lib "COMCTL32" (ByVal hImageList
 As Long, ByVal i As Long, ByVal hIcon As Long) As Long
Private Declare Function ImageList_Convert Lib "COMCTL32" Alias
 "ImageList_Draw" (ByVal hImageList As Long, ByVal ImgIndex As Long, ByVal
 hDCDest As Long, ByVal x As Long, ByVal y As Long, ByVal flags As Long) As Long
Private 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
Private Declare Function ImageList_AddMasked Lib "COMCTL32" (ByVal hImageList
 As Long, ByVal hbmImage As Long, ByVal crMask As Long) As Long
Private Declare Function ImageList_Replace Lib "COMCTL32" (ByVal hImageList As
 Long, ByVal ImgIndex As Long, ByVal hbmImage As Long, ByVal hBmMask As Long)
 As Long
Private Declare Function ImageList_Add Lib "COMCTL32" (ByVal hImageList As
 Long, ByVal hbmImage As Long, hBmMask As Long) As Long
Private Declare Function ImageList_Remove Lib "COMCTL32" (ByVal hImageList As
 Long, ByVal ImgIndex As Long) As Long
Private Type IMAGEINFO
    hBitmapImage As Long
    hBitmapMask As Long
    cPlanes As Long
    cBitsPerPixel As Long
    rcImage As RECT
End Type
Private Declare Function ImageList_GetImageInfo Lib "COMCTL32.DLL" ( _
        ByVal hIml As Long, _
        ByVal i As Long, _
        pImageInfo As IMAGEINFO _
    ) As Long
Private Declare Function ImageList_AddIcon Lib "COMCTL32" (ByVal hIml As Long,
 ByVal hIcon As Long) As Long
Private Declare Function ImageList_GetIcon Lib "COMCTL32" (ByVal hImageList As
 Long, ByVal ImgIndex As Long, ByVal fuFlags As Long) As Long
Private Declare Function ImageList_SetImageCount Lib "COMCTL32" (ByVal
 hImageList As Long, uNewCount As Long)
Private Declare Function ImageList_GetImageCount Lib "COMCTL32" (ByVal
 hImageList As Long) As Long
Private Declare Function ImageList_Destroy Lib "COMCTL32" (ByVal hImageList As
 Long) As Long
Private Declare Function ImageList_GetIconSize Lib "COMCTL32" (ByVal hImageList
 As Long, cX As Long, cY As Long) As Long
Private Declare Function ImageList_SetIconSize Lib "COMCTL32" (ByVal hImageList
 As Long, cX As Long, cY As Long) As Long

' ImageList functions:
' Draw:
Private 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 Long _
    ) As Long
Private Const ILD_NORMAL = 0&
Private Const ILD_TRANSPARENT = 1&
Private Const ILD_BLEND25 = 2&
Private Const ILD_SELECTED = 4&
Private Const ILD_FOCUS = 4&
Private Const ILD_MASK = &H10&
Private Const ILD_IMAGE = &H20&
Private Const ILD_ROP = &H40&
Private Const ILD_OVERLAYMASK = 3840&
Private Declare Function ImageList_GetImageRect Lib "COMCTL32.DLL" ( _
        ByVal hIml As Long, _
        ByVal i As Long, _
        prcImage As RECT _
    ) As Long
' Messages:
Private Declare Function ImageList_DrawEx Lib "COMCTL32" (ByVal hIml As Long,
 ByVal i As Long, ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, ByVal
 dx As Long, ByVal dy As Long, ByVal rgbBk As Long, ByVal rgbFg As Long, ByVal
 fStyle As Long) As Long
Private Declare Function ImageList_LoadImage Lib "COMCTL32" Alias
 "ImageList_LoadImageA" (ByVal hInst As Long, ByVal lpbmp As String, ByVal cX
 As Long, ByVal cGrow As Long, ByVal crMask As Long, ByVal uType As Long, ByVal
 uFlags As Long)
Private Declare Function ImageList_SetBkColor Lib "COMCTL32" (ByVal hImageList
 As Long, ByVal clrBk As Long) As Long

Private Const ILC_MASK = &H1&
 
Private Const CLR_DEFAULT = -16777216
Private Const CLR_HILIGHT = -16777216
Private Const CLR_NONE = -1

Private Const ILCF_MOVE = &H0&
Private Const ILCF_SWAP = &H1&
Private Declare Function ImageList_Copy Lib "COMCTL32" (ByVal himlDst As Long,
 ByVal iDst As Long, ByVal himlSrc As Long, ByVal iSrc As Long, ByVal uFlags As
 Long) As Long

Private Declare Function GetTempFileName Lib "kernel32" Alias
 "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String,
 ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal
 nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH = 260
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal
 lpString As String) As Long

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 OleCreatePictureIndirect Lib "olepro32.dll"
 (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic
 As IPicture) As Long

' -----------
' ENUMS
' -----------
Public Enum eilIconState
  Normal = 0
  Disabled = 1
End Enum

Public Enum ImageTypes
  IMAGE_BITMAP = 0
  IMAGE_ICON = 1
  IMAGE_CURSOR = 2
End Enum

Public Enum eilColourDepth
    ILC_COLOR = &H0
    ILC_COLOR4 = &H4
    ILC_COLOR8 = &H8
    ILC_COLOR16 = &H10
    ILC_COLOR24 = &H18
    ILC_COLOR32 = &H20
End Enum

Public Enum eilSwapTypes
   eilCopy = ILCF_MOVE
   eilSwap = ILCF_SWAP
End Enum

' ------------------
' Private variables:
' ------------------
Private m_hIml As Long
Private m_lIconSizeX As Long
Private m_lIconSizeY As Long
Private m_eColourDepth As eilColourDepth
Private m_sKey() As String
Private m_HDC As Long

Public Property Let OwnerHDC(ByVal lHDC As Long)
   m_HDC = lHDC
End Property

Public Property Get SystemColourDepth() As eilColourDepth
Dim lR As Long
Dim lHDC As Long
   lHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
   lR = GetDeviceCaps(lHDC, BITSPIXEL)
   DeleteDC lHDC
   SystemColourDepth = lR
End Property

Public Sub SwapOrCopyImage( _
      ByVal vKeySrc As Variant, _
      ByVal vKeyDst As Variant, _
      Optional ByVal eSwap As eilSwapTypes = eilSwap _
   )
Dim lDst As Long
Dim lSrc As Long
Dim sKeyDst As String
Dim sKeySrc As String

   If (m_hIml <> 0) Then
      lDst = ItemIndex(vKeySrc)
      If (lDst > -1) Then
         lSrc = ItemIndex(vKeyDst)
         If (lSrc > -1) Then
            ImageList_Copy m_hIml, lDst, m_hIml, lSrc, eSwap
            sKeyDst = m_sKey(lDst)
            sKeySrc = m_sKey(lSrc)
            m_sKey(lDst) = sKeySrc
            m_sKey(lSrc) = sKeyDst
         End If
      End If
   End If
End Sub

Public Function Create() As Boolean
     
     ' Do we already have an image list?  Kill it if we have:
    Destroy

    'Create the Imagelist:
    m_hIml = ImageList_Create(m_lIconSizeX, m_lIconSizeY, ILC_MASK Or
     m_eColourDepth, 4, 4)
    If (m_hIml <> 0) And (m_hIml <> -1) Then
      ' Ok
      Create = True
    Else
      m_hIml = 0
    End If
    
End Function
Public Sub Destroy()
   ' Kill the image list if we have one:
   If (hIml <> 0) Then
      ImageList_Destroy hIml
      m_hIml = 0
   End If
   Erase m_sKey
End Sub
Public Sub DrawImage( _
        ByVal vKey As Variant, _
        ByVal hdc As Long, _
        ByVal xPixels As Integer, _
        ByVal yPixels As Integer, _
        Optional ByVal bSelected = False, _
        Optional ByVal bCut = False, _
        Optional ByVal bDisabled = False, _
        Optional ByVal oCutDitherColour As OLE_COLOR = vbWindowBackground, _
        Optional ByVal hExternalIml As Long = 0 _
    )
Dim hIcon As Long
Dim lFlags As Long
Dim lhIml As Long
Dim lColor As Long
Dim iImgIndex As Long

   ' Draw the image at 1 based index or key supplied in vKey.
   ' on the hDC at xPixels,yPixels with the supplied options.
   ' You can even draw an ImageList from another ImageList control
   ' if you supply the handle to hExternalIml with this function.
   
   iImgIndex = ItemIndex(vKey)
   If (iImgIndex > -1) Then
      If (hExternalIml <> 0) Then
          lhIml = hExternalIml
      Else
          lhIml = hIml
      End If
      
      lFlags = ILD_TRANSPARENT
      If (bSelected) Or (bCut) Then
          lFlags = lFlags Or ILD_SELECTED
      End If
      
      If (bCut) Then
        ' Draw dithered:
        lColor = TranslateColor(oCutDitherColour)
        If (lColor = -1) Then lColor = GetSysColor(COLOR_WINDOW)
        ImageList_DrawEx _
              lhIml, _
              iImgIndex, _
              hdc, _
              xPixels, yPixels, 0, 0, _
              CLR_NONE, lColor, _
              lFlags
      ElseIf (bDisabled) Then
        ' extract a copy of the icon:
        hIcon = ImageList_GetIcon(hIml, iImgIndex, 0)
        ' Draw it disabled at x,y:
        DrawState hdc, 0, 0, hIcon, 0, xPixels, yPixels, m_lIconSizeX,
         m_lIconSizeY, DST_ICON Or DSS_DISABLED
        ' Clear up the icon:
        DestroyIcon hIcon
              
      Else
        ' Standard draw:
        ImageList_Draw _
            lhIml, _
            iImgIndex, _
            hdc, _
            xPixels, _
            yPixels, _
            lFlags
      End If
   End If
End Sub

Public Property Get IconSizeX() As Long
   ' Returns the icon width
    IconSizeX = m_lIconSizeX
End Property
Public Property Let IconSizeX(ByVal lSizeX As Long)
   ' Sets the icon width.  NB no change at runtime unless you
   ' call Create and add all the images in again.
    m_lIconSizeX = lSizeX
End Property
Public Property Get IconSizeY() As Long
   ' Returns the icon height:
    IconSizeY = m_lIconSizeY
End Property
Public Property Let IconSizeY(ByVal lSizeY As Long)
   ' Sets the icon height.  NB no change at runtime unless you
   ' call Create and add all the images in again.
    m_lIconSizeY = lSizeY
End Property
Public Property Get ColourDepth() As eilColourDepth
   ' Returns the ColourDepth:
    ColourDepth = m_eColourDepth
End Property
Public Property Let ColourDepth(ByVal eDepth As eilColourDepth)
   ' Sets the ColourDepth.  NB no change at runtime unless you
   ' call Create and rebuild the image list.
    m_eColourDepth = eDepth
End Property

Public Property Get ImageCount() As Integer
   ' Returns the number of images in the ImageList:
   If (hIml <> 0) Then
      ImageCount = ImageList_GetImageCount(hIml)
   End If
End Property
Public Sub RemoveImage(ByVal vKey As Variant)
Dim lIndex As Long
Dim i As Long
   ' Removes an image from the ImageList:
   If (hIml <> 0) Then
      lIndex = ItemIndex(vKey)
      ImageList_Remove hIml, lIndex
      ' Fix up the keys:
      For i = lIndex To ImageCount - 1
         m_sKey(i) = m_sKey(i + 1)
      Next i
      pEnsureKeys
   End If

End Sub
Public Property Get KeyExists(ByVal sKey As String) As Boolean
Dim iL As Long
Dim iU As Long
   If ImageCount > 0 Then
      On Error Resume Next
      iU = UBound(m_sKey)
      If Err.Number <> 0 Then
         iU = 0
      End If
      If (iU <> ImageCount - 1) Then
         pEnsureKeys
      End If
      For iL = 0 To ImageCount - 1
         If m_sKey(iL) = sKey Then
            KeyExists = True
            Exit For
         End If
      Next iL
   End If
End Property

Public Property Get ItemIndex(ByVal vKey As Variant) As Long
Dim lR As Long
Dim i As Long
   ' Returns the 0 based Index for the selected
   ' Image list item:
   If (IsNumeric(vKey)) Then
      lR = vKey
      If (lR > 0) And (lR <= ImageCount) Then
         ItemIndex = lR - 1
      Else
         ' error
         Err.Raise 9, App.EXEName & ".vbalImageList"
         ItemIndex = -1
      End If
   Else
      lR = -1
      For i = 0 To ImageCount - 1
         If (m_sKey(i) = vKey) Then
            lR = i
            Exit For
         End If
      Next i
      If (lR > 0) And (lR <= ImageCount) Then
         ItemIndex = lR
      Else
         Err.Raise 9, App.EXEName & ".vbalImageList"
         ItemIndex = -1
      End If
   End If
End Property
Public Property Get ItemKey(ByVal iIndex As Long) As Variant
   ' Returns the Key for an image:
   If (iIndex > 0) And (iIndex <= ImageCount) Then
      ItemKey = m_sKey(iIndex - 1)
   Else
      Err.Raise 9, App.EXEName & ".vbalImageList"
   End If
End Property
Public Property Let ItemKey(ByVal iIndex As Long, ByVal vKey As Variant)
   ' Sets the Key for the an image:
   iIndex = iIndex - 1
   If (iIndex > 0) And (iIndex < ImageCount) Then
      SetKey iIndex, vKey
   Else
      Err.Raise 9, App.EXEName & ".vbalImageList"
   End If
End Property
Public Property Get ItemPicture(ByVal vKey As Variant) As IPicture
Dim lIndex As Long
Dim hIcon As Long
   ' Returns a StdPicture for an image in the ImageList:
   lIndex = ItemIndex(vKey)
   If (lIndex > -1) Then
      hIcon = ImageList_GetIcon(m_hIml, lIndex, ILD_TRANSPARENT)
      If (hIcon <> 0) Then
         Set ItemPicture = IconToPicture(hIcon)
         ' Don't destroy the icon - it is now owned by
         ' the picture object
      End If
   End If
   
End Property
Public Property Get ItemCopyOfIcon(ByVal vKey As Variant) As Long
Dim lIndex As Long
   ' Returns a hIcon for an image in the ImageList.  User must
   ' call DestroyIcon on the returned handle.
   lIndex = ItemIndex(vKey)
   If (lIndex > -1) Then
      ItemCopyOfIcon = ImageList_GetIcon(m_hIml, lIndex, ILD_TRANSPARENT)
   End If
End Property
Public Sub Clear()
   ' Recreates the image list.
   Create
End Sub
Public Function AddFromFile( _
        ByVal sFIleName As String, _
        ByVal iType As ImageTypes, _
        Optional ByVal vKey As Variant, _
        Optional ByVal bMapSysColors As Boolean = False, _
        Optional ByVal lBackColor As OLE_COLOR = -1, _
        Optional ByVal vKeyAfter As Variant _
    ) As Long
Dim hImage As Long
Dim un2 As Long
Dim lR As Long
    
   ' Adds an image or series of images from a file:
   If (hIml <> 0) Then
      un2 = LR_LOADFROMFILE
      ' Load the image from file:
      If bMapSysColors Then
          un2 = un2 Or LR_LOADMAP3DCOLORS
      End If
      hImage = LoadImage(App.hInstance, sFIleName, iType, 0, 0, un2)
      AddFromFile = AddFromHandle(hImage, iType, vKey, lBackColor, vKeyAfter)
      Select Case iType
      Case IMAGE_ICON
         DestroyIcon hImage
      Case IMAGE_CURSOR
         DestroyCursor hImage
      Case IMAGE_BITMAP
         DeleteObject hImage
      End Select
   Else
      ' no image list...
      AddFromFile = False
   End If
                  
End Function
Public Function AddFromResourceID( _
      ByVal lID As Long, _
      ByVal hInst As Long, _
      ByVal iType As ImageTypes, _
      Optional ByVal vKey As Variant, _
      Optional ByVal bMapSysColors As Boolean = False, _
      Optional ByVal lBackColor As OLE_COLOR = -1, _
      Optional ByVal vKeyAfter As Variant _
    ) As Long
Dim hImage As Long
Dim un2 As Long
Dim lR As Long
Dim iX As Long, iY As Long
    
   ' Adds an image or series of images from a resource id.  Note this will
   ' only work when working on a resource in a compiled executable:
   If (hIml <> 0) Then
      ' Load the image from file:
      If bMapSysColors Then
          un2 = un2 Or LR_LOADMAP3DCOLORS
      End If
      ' Choose the icon closest to the image list size:
      If iType <> IMAGE_BITMAP Then
         iX = m_lIconSizeX
         iY = m_lIconSizeY
      End If
      If hInst = 0 Then
         ' Assume we're trying to pick a shared
         ' resource
         un2 = un2 Or LR_COPYRETURNORG
      End If
      hImage = LoadImageLong(hInst, lID, iType, iX, iY, un2)
      AddFromResourceID = AddFromHandle(hImage, iType, vKey, lBackColor,
       vKeyAfter)
      Select Case iType
      Case IMAGE_ICON
         DestroyIcon hImage
      Case IMAGE_CURSOR
         DestroyCursor hImage
      Case IMAGE_BITMAP
         DeleteObject hImage
      End Select
   Else
      ' no image list...
      AddFromResourceID = False
   End If
   
End Function

Public Function AddFromHandle( _
      ByVal hImage As Long, _
      ByVal iType As ImageTypes, _
      Optional ByVal vKey As Variant, _
      Optional ByVal lBackColor As OLE_COLOR = -1, _
      Optional ByVal vKeyAfter As Variant _
   ) As Boolean
Dim lR As Long
Dim lDst As Long
Dim bOk As Boolean
Dim bInsert As Boolean
Dim i As Long, j As Long
Dim iOrigCount As Long
Dim iCount As Long
Dim sSwapKey As String

   ' Adds an image or series of images from a GDI image handle.
   If (m_hIml <> 0) Then
      If (hImage <> 0) Then
         iOrigCount = ImageCount
         
         bOk = True
         If Not IsMissing(vKeyAfter) Then
            If (ImageCount > 0) Then
               If vKeyAfter = 0 Then
                  bInsert = False
                  lDst = 0
               Else
                  bInsert = True
                  bOk = False
                  lDst = ItemIndex(vKeyAfter)
                  If (lDst > -1) Then
                     bOk = True
                  End If
               End If
            End If
         End If
         
         If (bOk) Then
            If (iType = IMAGE_BITMAP) Then
               ' And add it to the image list:
               If (lBackColor = -1) Then
                   ' Ideally Determine the top left pixel of the
                   ' bitmap and use as back colour...
                   Dim lHDCDisp As Long, lHDC As Long, hBmpOld As Long
                   lHDCDisp = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&,
                    ByVal 0&)
                   If lHDCDisp <> 0 Then
                     lHDC = CreateCompatibleDC(lHDCDisp)
                     DeleteDC lHDCDisp
                     If lHDC <> 0 Then
                        hBmpOld = SelectObject(lHDC, hImage)
                        If hBmpOld <> 0 Then
                           ' Get the colour of the 0,0 pixel:
                           lBackColor = GetPixel(lHDC, 0, 0)
                           SelectObject lHDC, hBmpOld
                        End If
                        DeleteObject lHDC
                     End If
                  End If
               End If
               lR = ImageList_AddMasked(hIml, hImage, lBackColor)
            ElseIf (iType = IMAGE_ICON) Or (iType = IMAGE_CURSOR) Then
               ' Add the icon:
               lR = ImageList_AddIcon(hIml, hImage)
            End If
         End If
         
         If (lR > -1) Then
            If (bInsert) Then
               If (lDst < ImageCount - 1) Then
                  ' We are inserting and have to swap all
                  ' the images.
                  pEnsureKeys
                  iCount = ImageCount
                  For i = iOrigCount - 1 To lDst Step -1
                     For j = i To i + iCount - iOrigCount - 1
                        ImageList_Copy m_hIml, j + 1, m_hIml, j, eilSwap
                        sSwapKey = m_sKey(j)
                        m_sKey(j) = m_sKey(j + 1)
                        m_sKey(j + 1) = sSwapKey
                     Next j
                  Next i
                  
               End If
            End If
         End If
         
      Else
          lR = -1
      End If
   Else
      lR = -1
   End If
   
   If (lR <> -1) Then
      If bInsert Then
         SetKey lDst, vKey
      Else
         SetKey lR, vKey
      End If
      AddFromHandle = (lR <> -1)
   End If
   pEnsureKeys
   
End Function
Public Function AddFromPictureBox( _
        ByVal hdc As Long, _
        pic As Object, _
        Optional ByVal vKey As Variant, _
        Optional ByVal LeftPixels As Long = 0, _
        Optional ByVal TopPixels As Long = 0, _
        Optional ByVal lBackColor As OLE_COLOR = -1 _
    ) As Long
Dim lHDC As Long
Dim lhBmp As Long, lhBmpOld As Long
Dim tBM As BITMAP
Dim lAColor As Long
Dim lW As Long, lH As Long
Dim hBrush As Long
Dim tR As RECT
Dim lR As Long
Dim lBPixel As Long
   
   ' Adds an image or series of images from an area of a PictureBox
   ' or other Device Context:
   lR = -1
   If (hIml <> 0) Then
      ' Create a DC to hold the bitmap to transfer into the image list:
      lHDC = CreateCompatibleDC(hdc)
      If (lHDC <> 0) Then
          lhBmp = CreateCompatibleBitmap(hdc, m_lIconSizeX, m_lIconSizeY)
          If (lhBmp <> 0) Then
              ' Get the backcolor to use:
              If (lBackColor = -1) Then
                  ' None specified, use the colour at 0,0:
                  lBackColor = GetPixel(pic.hdc, 0, 0)
              Else
                  ' Try to get the specified backcolor:
                  If OleTranslateColor(lBackColor, 0, lAColor) Then
                      ' Failed- use default of silver
                      lBackColor = &HC0C0C0
                  Else
                      ' Set to GDI version of OLE Color
                      lBackColor = lAColor
                  End If
              End If
              ' Select the bitmap into the DC
              lhBmpOld = SelectObject(lHDC, lhBmp)
              ' Clear the background:
              hBrush = CreateSolidBrush(lBackColor)
              tR.Right = m_lIconSizeX: tR.Bottom = m_lIconSizeY
              FillRect lHDC, tR, hBrush
              DeleteObject hBrush
              
              ' Get the source picture's dimension:
              GetObjectAPI pic.Picture.Handle, LenB(tBM), tBM
              lW = 16
              lH = 16
              If (lW + LeftPixels > tBM.bmWidth) Then
                  lW = tBM.bmWidth - LeftPixels
              End If
              If (lH + TopPixels > tBM.bmHeight) Then
                  lH = tBM.bmHeight - TopPixels
              End If
              If (lW > 0) And (lH > 0) Then
                  ' Blt from the picture into the bitmap:
                  lR = BitBlt(lHDC, 0, 0, lW, lH, hdc, LeftPixels, TopPixels,
                   SRCCOPY)
                  Debug.Assert (lR <> 0)
              End If
              
              ' We now have the image in the bitmap, so select it out of the DC:
              SelectObject lHDC, lhBmpOld
              ' And add it to the image list:
              AddFromHandle lhBmp, IMAGE_BITMAP, vKey, lBackColor
                  
              DeleteObject lhBmp
          End If
          ' Clear up the DC:
          DeleteDC lHDC
      End If
   End If

   If (lR <> -1) Then
        SetKey lR, vKey
   End If
   
   AddFromPictureBox = lR + 1
   pEnsureKeys
   
End Function
Private Sub SetKey(ByVal lIndex As Long, ByVal vKey As Variant)
Dim sKey As String
Dim lI As Long

   If (IsEmpty(vKey) Or IsMissing(vKey)) Then
      sKey = ""
   Else
      sKey = vKey
   End If
    
   If (m_hIml <> 0) Then
      
      On Error Resume Next
      lI = UBound(m_sKey)
      If (Err.Number = 0) Then
         If (lIndex > lI) Then
            ReDim Preserve m_sKey(0 To lIndex) As String
         End If
      Else
         ReDim Preserve m_sKey(0 To lIndex) As String
      End If
      
      For lI = 0 To UBound(m_sKey)
         If Not lI = lIndex Then
            If Trim$(m_sKey(lI)) <> "" Then
               If m_sKey(lI) = vKey Then
                  Err.Raise 457
                  Exit Sub
               End If
            End If
         End If
      Next lI
      m_sKey(lIndex) = vKey
   End If
End Sub
Public Property Get hIml() As Long
   ' Returns the ImageList handle:
    hIml = m_hIml
End Property
Public Property Get ImagePictureStrip( _
      Optional ByVal vStartKey As Variant, _
      Optional ByVal vEndKey As Variant, _
      Optional ByVal oBackColor As OLE_COLOR = vbButtonFace _
   ) As IPicture
Dim iStart As Long
Dim iEnd As Long
Dim iImgIndex As Long
Dim lHDC As Long
Dim lParenthDC As Long
Dim lhBmp As Long
Dim lhBmpOld As Long
Dim lSizeX As Long
Dim hBr As Long
Dim tR As RECT
Dim lColor As Long
   
   If (m_hIml <> 0) Then
      If (IsMissing(vStartKey)) Then
         iStart = 0
      Else
         iStart = ItemIndex(vStartKey)
      End If
      If (IsMissing(vEndKey)) Then
         iEnd = ImageCount - 1
      Else
         iEnd = ItemIndex(vEndKey)
      End If
      
      If (iEnd > iStart) And (iEnd > -1) Then
         lParenthDC = m_HDC
         lHDC = CreateCompatibleDC(lParenthDC)
         If (lHDC <> 0) Then
            lSizeX = ImageCount * m_lIconSizeX
            lhBmp = CreateCompatibleBitmap(lParenthDC, lSizeX, m_lIconSizeY)
            If (lhBmp <> 0) Then
               lhBmpOld = SelectObject(lHDC, lhBmp)
               If (lhBmpOld <> 0) Then
                  lColor = TranslateColor(oBackColor)
                  tR.Bottom = m_lIconSizeY
                  tR.Right = lSizeX
                  hBr = CreateSolidBrush(lColor)
                  FillRect lHDC, tR, hBr
                  DeleteObject hBr
                  For iImgIndex = iStart To iEnd
                     ImageList_Draw m_hIml, iImgIndex, lHDC, iImgIndex *
                      m_lIconSizeX, 0, ILD_TRANSPARENT
                  Next iImgIndex
                  SelectObject lHDC, lhBmpOld
                  Set ImagePictureStrip = BitmapToPicture(lhBmp)
               Else
                  DeleteObject lhBmp
               End If
            End If
            DeleteDC lHDC
         End If
      End If
   End If
   
End Property

Public Function IconToPicture(ByVal hIcon As Long) As IPicture
    
    If hIcon = 0 Then Exit Function
        
    ' This is all magic if you ask me:
    Dim NewPic As Picture, PicConv As PictDesc, IGuid As Guid
    
    PicConv.cbSizeofStruct = Len(PicConv)
    PicConv.picType = vbPicTypeIcon
    PicConv.hImage = hIcon
    
    ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    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 PicConv, IGuid, True, NewPic
    
    Set IconToPicture = NewPic
    
End Function

Public Function BitmapToPicture(ByVal hBmp As Long) As IPicture

   If (hBmp = 0) Then Exit Function
   
   Dim NewPic As Picture, tPicConv As PictDesc, IGuid As Guid
   
   ' Fill PictDesc structure with necessary parts:
   With tPicConv
      .cbSizeofStruct = Len(tPicConv)
      .picType = vbPicTypeBitmap
      .hImage = hBmp
   End With
   
   ' Fill in IDispatch Interface ID
   With IGuid
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
   End With
   
   ' Create a picture object:
   OleCreatePictureIndirect tPicConv, IGuid, True, NewPic
   
   ' Return it:
   Set BitmapToPicture = NewPic
      

End Function

Public Function TranslateColor(ByVal clr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
   If OleTranslateColor(clr, hPal, TranslateColor) Then
      TranslateColor = CLR_INVALID
   End If
End Function
Private Sub pEnsureKeys()
Dim iCount As Long
Dim iU As Long
   If m_hIml <> 0 Then
      iCount = ImageCount
      On Error Resume Next
      iU = UBound(m_sKey)
      If (Err.Number <> 0) Then iU = -1
      Err.Clear
      If (iU <> iCount - 1) Then
         ReDim Preserve m_sKey(0 To iCount - 1) As String
      End If
   End If
End Sub

Private Sub Class_Initialize()
   m_lIconSizeX = 16
   m_lIconSizeY = 16
   m_eColourDepth = ILC_COLOR
End Sub

Private Sub Class_Terminate()
    Destroy
End Sub