home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Integrate_2056313262007.psc / clsImageList.cls < prev    next >
Text File  |  2007-03-26  |  60KB  |  1,641 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsImageList"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15. '/* based on the vbaccelerator imagelist control, with rewrites and additions:
  16. '/* http://www.vbaccelerator.com/home/VB/Code/Controls/ImageList/vbAccelerator_Image_List_Control/article.asp
  17.  
  18.  
  19. Private Const BI_RGB                            As Long = 0
  20.  
  21. Private Const BITSPIXEL                         As Long = 12
  22.  
  23. Private Const CLR_INVALID                       As Long = -1
  24. Private Const CLR_NONE                          As Long = -1
  25. Private Const COLOR_WINDOW                      As Long = &H5
  26.  
  27. Private Const DIB_RGB_COLORS                    As Long = 0
  28.  
  29. Private Const DSS_DISABLED                      As Long = &H20
  30.  
  31. Private Const DST_ICON                          As Long = &H3
  32.  
  33. Private Const FILE_ATTRIBUTE_NORMAL             As Long = &H80
  34.  
  35. Private Const ILCF_MOVE                         As Long = &H0
  36. Private Const ILCF_SWAP                         As Long = &H1
  37.  
  38. Private Const ILD_NORMAL                        As Long = &H0
  39. Private Const ILD_TRANSPARENT                   As Long = &H1
  40. Private Const ILD_BLEND25                       As Long = &H2
  41. Private Const ILD_SELECTED                      As Long = &H4
  42. Private Const ILD_FOCUS                         As Long = &H8
  43. Private Const ILD_MASK                          As Long = &H10
  44. Private Const ILD_IMAGE                         As Long = &H20
  45. Private Const ILD_ROP                           As Long = &H40
  46.  
  47. Private Const LR_LOADMAP3DCOLORS                As Long = &H1000
  48. Private Const LR_LOADFROMFILE                   As Long = &H10
  49. Private Const LR_COPYRETURNORG                  As Long = &H4
  50.  
  51. Private Const MAX_PATH                          As Long = 260
  52.  
  53. Private Const SHGFI_ICON                        As Long = &H100
  54. Private Const SHGFI_SYSICONINDEX                As Long = &H4000
  55. Private Const SHGFI_LARGEICON                   As Long = &H0
  56. Private Const SHGFI_SMALLICON                   As Long = &H1
  57. Private Const SHGFI_OPENICON                    As Long = &H2
  58. Private Const SHGFI_SHELLICONSIZE               As Long = &H4
  59. Private Const SHGFI_USEFILEATTRIBUTES           As Long = &H10
  60.  
  61. Private Const ICON_FLAGS                        As Long = _
  62.     SHGFI_USEFILEATTRIBUTES Or SHGFI_SYSICONINDEX
  63.  
  64. Private Const VER_PLATFORM_WIN32_NT             As Long = 2
  65.  
  66.  
  67. Private Enum ImageLockMode
  68.     ImageLockModeRead = &H1
  69.     ImageLockModeWrite = &H2
  70.     ImageLockModeUserInputBuf = &H4
  71. End Enum
  72.  
  73. Private Enum PixelFormat
  74.     PixelFormatIndexed = &H10000
  75.     PixelFormatGDI = &H20000
  76.     PixelFormatAlpha = &H40000
  77.     PixelFormatPAlpha = &H80000
  78.     PixelFormatExtended = &H100000
  79.     PixelFormatCanonical = &H200000
  80.     PixelFormatUndefined = 0
  81.     PixelFormatDontCare = 0
  82.     PixelFormat1bppIndexed = &H30101
  83.     PixelFormat4bppIndexed = &H30402
  84.     PixelFormat8bppIndexed = &H30803
  85.     PixelFormat16bppGreyScale = &H101004
  86.     PixelFormat16bppRGB555 = &H21005
  87.     PixelFormat16bppRGB565 = &H21006
  88.     PixelFormat16bppARGB1555 = &H61007
  89.     PixelFormat24bppRGB = &H21808
  90.     PixelFormat32bppRGB = &H22009
  91.     PixelFormat32bppARGB = &H26200A
  92.     PixelFormat32bppPARGB = &HE200B
  93.     PixelFormat48bppRGB = &H10300C
  94.     PixelFormat64bppARGB = &H34400D
  95.     PixelFormat64bppPARGB = &H1C400E
  96.     PixelFormatMax = 15
  97. End Enum
  98.  
  99. Private Enum PaletteFlags
  100.     PaletteFlagsHasAlpha = &H1
  101.     PaletteFlagsGrayScale = &H2
  102.     PaletteFlagsHalftone = &H4
  103. End Enum
  104.  
  105. Public Enum EISIconSize
  106.     eisLargeIcon = SHGFI_LARGEICON
  107.     eisOpenIcon = SHGFI_OPENICON
  108.     eisShellIcon = SHGFI_SHELLICONSIZE
  109.     eisSmallIcon = SHGFI_SMALLICON
  110. End Enum
  111.  
  112. Public Enum EILDrawState
  113.     ildNormal = 0
  114.     ildDisabled = 1
  115.     ildSelected = 2
  116.     ildColored = 3
  117.     ildCutDisabled = 4
  118. End Enum
  119.  
  120. Public Enum EILImageTypes
  121.     IMAGE_BITMAP = 0
  122.     IMAGE_ICON = 1
  123.     IMAGE_CURSOR = 2
  124. End Enum
  125.  
  126. Public Enum EILColourDepth
  127.     ILC_COLOR = &H0
  128.     ILC_MASK = &H1
  129.     ILC_COLOR4 = &H4
  130.     ILC_COLOR8 = &H8
  131.     ILC_COLOR16 = &H10
  132.     ILC_COLOR24 = &H18
  133.     ILC_COLOR32 = &H20
  134. End Enum
  135.  
  136. Public Enum EILSwapTypes
  137.     ilsCopy = ILCF_MOVE
  138.     ilsSwap = ILCF_SWAP
  139. End Enum
  140.  
  141.  
  142. Private Type GdiplusStartupInput
  143.    GdiplusVersion                               As Long
  144.    DebugEventCallback                           As Long
  145.    SuppressBackgroundThread                     As Long
  146.    SuppressExternalCodecs                       As Long
  147. End Type
  148.  
  149. Private Type bitmap
  150.     bmType                                      As Long
  151.     bmWidth                                     As Long
  152.     bmHeight                                    As Long
  153.     bmWidthBytes                                As Long
  154.     bmPlanes                                    As Long
  155.     bmBitsPixel                                 As Long
  156.     bmBits                                      As Long
  157. End Type
  158.  
  159. Private Type BITMAPINFOHEADER
  160.     biSize                                      As Long
  161.     biWidth                                     As Long
  162.     biHeight                                    As Long
  163.     biPlanes                                    As Integer
  164.     biBitCount                                  As Integer
  165.     biCompression                               As Long
  166.     biSizeImage                                 As Long
  167.     biXPelsPerMeter                             As Long
  168.     biYPelsPerMeter                             As Long
  169.     biClrUsed                                   As Long
  170.     biClrImportant                              As Long
  171. End Type
  172.  
  173. Private Type RGBQUAD
  174.     rgbBlue                                     As Byte
  175.     rgbGreen                                    As Byte
  176.     rgbRed                                      As Byte
  177.     rgbReserved                                 As Byte
  178. End Type
  179.  
  180. Private Type BITMAPDATA
  181.     Width                                       As Long
  182.     Height                                      As Long
  183.     stride                                      As Long
  184.     PixelFormat                                 As Long
  185.     scan0                                       As Long
  186.     Reserved                                    As Long
  187. End Type
  188.  
  189. Private Type RECT
  190.     left                                        As Long
  191.     top                                         As Long
  192.     Right                                       As Long
  193.     Bottom                                      As Long
  194. End Type
  195.  
  196. Private Type IMAGEINFO
  197.     hBitmapImage                                As Long
  198.     hBitmapMask                                 As Long
  199.     cPlanes                                     As Long
  200.     cBitsPerPixel                               As Long
  201.     rcImage                                     As RECT
  202. End Type
  203.  
  204. Private Type PictDesc
  205.     cbSizeofStruct                              As Long
  206.     picType                                     As Long
  207.     hImage                                      As Long
  208.     xExt                                        As Long
  209.     yExt                                        As Long
  210. End Type
  211.  
  212. Private Type Guid
  213.     Data1                                       As Long
  214.     Data2                                       As Integer
  215.     Data3                                       As Integer
  216.     Data4(0 To 7)                               As Byte
  217. End Type
  218.  
  219.  
  220. Private Type ICONINFO
  221.     fIcon                                       As Long
  222.     xHotspot                                    As Long
  223.     yHotspot                                    As Long
  224.     hBmMask                                     As Long
  225.     hbmColor                                    As Long
  226. End Type
  227.  
  228. Private Type BITMAPINFO_1BPP
  229.     bmiHeader                                   As BITMAPINFOHEADER
  230.     bmiColors(0 To 1)                           As RGBQUAD
  231. End Type
  232.  
  233. Private Type BITMAPINFO_ABOVE8
  234.     bmiHeader                                   As BITMAPINFOHEADER
  235. End Type
  236.  
  237. Private Type tagINITCOMMONCONTROLSEX
  238.     dwSize                                      As Long
  239.     dwICC                                       As Long
  240. End Type
  241.  
  242. Private Type OSVERSIONINFO
  243.     dwVersionInfoSize                           As Long
  244.     dwMajorVersion                              As Long
  245.     dwMinorVersion                              As Long
  246.     dwBuildNumber                               As Long
  247.     dwPlatformId                                As Long
  248.     szCSDVersion(0 To 127)                      As Byte
  249. End Type
  250.  
  251. Private Type SHFILEINFOA
  252.     hicon                                       As Long
  253.     iIcon                                       As Long
  254.     dwAttributes                                As Long
  255.     szDisplayName                               As String * MAX_PATH
  256.     szTypeName                                  As String * 80
  257. End Type
  258.  
  259. Private Type SHFILEINFOW
  260.     hicon                                       As Long
  261.     iIcon                                       As Long
  262.     dwAttributes                                As Long
  263.     szDisplayName(MAX_PATH)                     As Byte
  264.     szTypeName(80)                              As Byte
  265. End Type
  266.  
  267.  
  268.  
  269. Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
  270.  
  271. Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As String) As Long
  272.  
  273. Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
  274.  
  275. Private Declare Function LoadLibraryW Lib "kernel32" (ByVal lpLibFileName As String) As Long
  276.  
  277. Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
  278.  
  279. Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
  280.                                                         ByVal lpProcName As String) As Long
  281.  
  282. Private Declare Function SHGetFileInfoA Lib "shell32.dll" (ByVal pszPath As String, _
  283.                                                            ByVal dwAttributes As Long, _
  284.                                                            psfi As SHFILEINFOA, _
  285.                                                            ByVal cbSizeFileInfo As Long, _
  286.                                                            ByVal uFlags As Long) As Long
  287.  
  288. Private Declare Function SHGetFileInfoW Lib "shell32.dll" (ByVal pszPath As Long, _
  289.                                                            ByVal dwAttributes As Long, _
  290.                                                            psfi As SHFILEINFOW, _
  291.                                                            ByVal cbSizeFileInfo As Long, _
  292.                                                            ByVal uFlags As Long) As Long
  293.  
  294. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  295.  
  296. Private Declare Function GetIconInfo Lib "user32" (ByVal hicon As Long, _
  297.                                                    piconinfo As ICONINFO) As Long
  298.  
  299. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, _
  300.                                                                       ByVal nCount As Long, _
  301.                                                                       lpObject As Any) As Long
  302.  
  303. Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
  304.  
  305. Private Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As bitmap) As Long
  306.  
  307. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, _
  308.                                                              ByVal nWidth As Long, _
  309.                                                              ByVal nHeight As Long) As Long
  310.  
  311. Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, _
  312.                                                 ByVal hBitmap As Long, _
  313.                                                 ByVal nStartScan As Long, _
  314.                                                 ByVal nNumScans As Long, _
  315.                                                 lpBits As Any, _
  316.                                                 lpBI As Any, _
  317.                                                 ByVal wUsage As Long) As Long
  318.  
  319. Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, _
  320.                                                 ByVal hBitmap As Long, _
  321.                                                 ByVal nStartScan As Long, _
  322.                                                 ByVal nNumScans As Long, _
  323.                                                 lpBits As Any, _
  324.                                                 lpBI As Any, _
  325.                                                 ByVal wUsage As Long) As Long
  326.  
  327. Private Declare Sub RtlMoveMemory Lib "kernel32" (lpvDest As Any, _
  328.                                                   lpvSource As Any, _
  329.                                                   ByVal cbCopy As Long)
  330.  
  331. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
  332.                                                    ByVal hObject As Long) As Long
  333.  
  334. Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
  335.  
  336. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  337.  
  338. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  339.  
  340. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
  341.                                                     ByVal nIndex As Long) As Long
  342.  
  343. Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, _
  344.                                                ByVal x As Long, _
  345.                                                ByVal y As Long) As Long
  346.  
  347. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  348.  
  349. Private Declare Function DestroyIcon Lib "user32" (ByVal hicon As Long) As Long
  350.  
  351. Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, _
  352.                                                                     ByVal lpsz As String, _
  353.                                                                     ByVal un1 As Long, _
  354.                                                                     ByVal n1 As Long, _
  355.                                                                     ByVal n2 As Long, _
  356.                                                                     ByVal un2 As Long) As Long
  357.  
  358. Private Declare Function LoadImageLong Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, _
  359.                                                                         ByVal lpsz As Long, _
  360.                                                                         ByVal un1 As Long, _
  361.                                                                         ByVal n1 As Long, _
  362.                                                                         ByVal n2 As Long, _
  363.                                                                         ByVal un2 As Long) As Long
  364.  
  365. Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, _
  366.                                                                        lpDeviceName As Any, _
  367.                                                                        lpOutput As Any, _
  368.                                                                        lpInitData As Any) As Long
  369.  
  370. Private Declare Function DrawState Lib "user32" Alias "DrawStateA" (ByVal hdc As Long, _
  371.                                                                     ByVal hBrush As Long, _
  372.                                                                     ByVal lpDrawStateProc As Long, _
  373.                                                                     ByVal lParam As Long, _
  374.                                                                     ByVal wParam As Long, _
  375.                                                                     ByVal x As Long, _
  376.                                                                     ByVal y As Long, _
  377.                                                                     ByVal cx As Long, _
  378.                                                                     ByVal cy As Long, _
  379.                                                                     ByVal fuFlags As Long) As Long
  380.  
  381. Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, _
  382.                                                                ByVal HPALETTE As Long, _
  383.                                                                pccolorref As Long) As Long
  384.  
  385. Private Declare Function ImageList_GetBkColor Lib "comctl32" (ByVal hImageList As Long) As Long
  386.  
  387. Private Declare Function ImageList_ReplaceIcon Lib "comctl32" (ByVal hImageList As Long, _
  388.                                                                ByVal I As Long, _
  389.                                                                ByVal hicon As Long) As Long
  390.  
  391. Private Declare Function ImageList_Convert Lib "comctl32" Alias "ImageList_Draw" (ByVal hImageList As Long, _
  392.                                                                                   ByVal ImgIndex As Long, _
  393.                                                                                   ByVal hDCDest As Long, _
  394.                                                                                   ByVal x As Long, _
  395.                                                                                   ByVal y As Long, _
  396.                                                                                   ByVal flags As Long) As Long
  397.  
  398. Private Declare Function ImageList_Create Lib "comctl32" (ByVal MinCx As Long, _
  399.                                                           ByVal MinCy As Long, _
  400.                                                           ByVal flags As Long, _
  401.                                                           ByVal cInitial As Long, _
  402.                                                           ByVal cGrow As Long) As Long
  403.  
  404. Private Declare Function ImageList_AddMasked Lib "comctl32" (ByVal hImageList As Long, _
  405.                                                              ByVal hbmImage As Long, _
  406.                                                              ByVal crMask As Long) As Long
  407.  
  408. Private Declare Function ImageList_Replace Lib "comctl32" (ByVal hImageList As Long, _
  409.                                                            ByVal ImgIndex As Long, _
  410.                                                            ByVal hbmImage As Long, _
  411.                                                            ByVal hBmMask As Long) As Long
  412.  
  413. Private Declare Function ImageList_Add Lib "comctl32" (ByVal hImageList As Long, _
  414.                                                        ByVal hbmImage As Long, _
  415.                                                        hBmMask As Long) As Long
  416.  
  417. Private Declare Function ImageList_Remove Lib "comctl32" (ByVal hImageList As Long, _
  418.                                                           ByVal ImgIndex As Long) As Long
  419.  
  420. Private Declare Function ImageList_GetImageInfo Lib "comctl32" (ByVal hIml As Long, _
  421.                                                                 ByVal I As Long, _
  422.                                                                 pImageInfo As IMAGEINFO) As Long
  423.  
  424. Private Declare Function ImageList_AddIcon Lib "comctl32" (ByVal hIml As Long, _
  425.                                                            ByVal hicon As Long) As Long
  426.  
  427. Private Declare Function ImageList_GetIcon Lib "comctl32" (ByVal hImageList As Long, _
  428.                                                            ByVal ImgIndex As Long, _
  429.                                                            ByVal fuFlags As Long) As Long
  430.  
  431. Private Declare Function ImageList_SetImageCount Lib "comctl32" (ByVal hImageList As Long, _
  432.                                                                  uNewCount As Long)
  433.  
  434. Private Declare Function ImageList_GetImageCount Lib "comctl32" (ByVal hImageList As Long) As Long
  435.  
  436. Private Declare Function ImageList_Destroy Lib "comctl32" (ByVal hImageList As Long) As Long
  437.  
  438. Private Declare Function ImageList_GetIconSize Lib "comctl32" (ByVal hImageList As Long, _
  439.                                                                cx As Long, _
  440.                                                                cy As Long) As Long
  441.  
  442. Private Declare Function ImageList_SetIconSize Lib "comctl32" (ByVal hImageList As Long, _
  443.                                                                cx As Long, _
  444.                                                                cy As Long) As Long
  445.  
  446. Private Declare Function ImageList_Draw Lib "comctl32" (ByVal hIml As Long, _
  447.                                                         ByVal I As Long, _
  448.                                                         ByVal hdcDst As Long, _
  449.                                                         ByVal x As Long, _
  450.                                                         ByVal y As Long, _
  451.                                                         ByVal fStyle As Long) As Long
  452.  
  453. Private Declare Function ImageList_DrawEx Lib "comctl32" (ByVal hIml As Long, _
  454.                                                           ByVal I As Long, _
  455.                                                           ByVal hdcDst As Long, _
  456.                                                           ByVal x As Long, _
  457.                                                           ByVal y As Long, _
  458.                                                           ByVal dx As Long, _
  459.                                                           ByVal dy As Long, _
  460.                                                           ByVal rgbBk As Long, _
  461.                                                           ByVal rgbFg As Long, _
  462.                                                           ByVal fStyle As Long) As Long
  463.  
  464. Private Declare Function ImageList_Copy Lib "comctl32" (ByVal himlDst As Long, _
  465.                                                         ByVal iDst As Long, _
  466.                                                         ByVal himlSrc As Long, _
  467.                                                         ByVal iSrc As Long, _
  468.                                                         ByVal uFlags As Long) As Long
  469.  
  470. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, _
  471.                                                                       riid As Guid, _
  472.                                                                       ByVal fPictureOwnsHandle As Long, _
  473.                                                                       ipic As IPicture) As Long
  474.  
  475. Private Declare Function InitCommonControls Lib "comctl32" () As Boolean
  476.  
  477. Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersion As OSVERSIONINFO) As Long
  478.  
  479. Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, _
  480.                                                        inputbuf As GdiplusStartupInput, _
  481.                                                        Optional ByVal outputbuf As Long = 0) As Long
  482.  
  483. Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
  484.  
  485. Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, _
  486.                                                           graphics As Long) As Long
  487.  
  488. Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, _
  489.                                                           Width As Long) As Long
  490.  
  491. Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, _
  492.                                                            Height As Long) As Long
  493.  
  494. Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
  495.  
  496. Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
  497.  
  498. Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, _
  499.                                                                     ByVal hpal As Long, _
  500.                                                                     bmap As Long) As Long
  501.  
  502. Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal graphics As Long, _
  503.                                                       ByVal image As Long, _
  504.                                                       ByVal x As Single, _
  505.                                                       ByVal y As Single) As Long
  506.  
  507. Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" (ByVal lImage As Long, _
  508.                                                                 lFormat As Long) As Long
  509.  
  510. Private Declare Function GdipBitmapLockBits Lib "gdiplus" (ByVal bitmap As Long, _
  511.                                                            rc As RECT, _
  512.                                                            ByVal flags As ImageLockMode, _
  513.                                                            ByVal PixelFormat As Long, _
  514.                                                            lockedBitmapData As BITMAPDATA) As Long
  515.  
  516. Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, _
  517.                                                                   ByVal Height As Long, _
  518.                                                                   ByVal stride As Long, _
  519.                                                                   ByVal PixelFormat As Long, _
  520.                                                                   scan0 As Any, bitmap As Long) As Long
  521.  
  522. Private Declare Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal bitmap As Long, _
  523.                                                              lockedBitmapData As BITMAPDATA) As Long
  524.  
  525. Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As Long, _
  526.                                                            ByVal x As Long, _
  527.                                                            ByVal y As Long, _
  528.                                                            color As Long) As Long
  529.  
  530.  
  531. Private m_bIsXp                                 As Boolean
  532. Private m_bIsNt                                 As Boolean
  533. Private m_bGdiPlusLoaded                        As Boolean
  534. Private m_hIml                                  As Long
  535. Private m_lIconSizeX                            As Long
  536. Private m_lIconSizeY                            As Long
  537. Private m_lOwnerDc                              As Long
  538. Private m_lGdiPlusToken                         As Long
  539. Private m_eColourDepth                          As EILColourDepth
  540. Private m_sImlName                              As String
  541. Private m_cKeys                                 As Collection
  542.  
  543.  
  544. Private Sub Class_Initialize()
  545.  
  546.     m_lIconSizeX = 16
  547.     m_lIconSizeY = 16
  548.     m_eColourDepth = ILC_COLOR
  549.     Set m_cKeys = New Collection
  550.     InitCommonControls
  551.     VersionCheck
  552.     If LibraryExists("gdiplus") Then
  553.         LoadGdiPlus
  554.     End If
  555.     
  556. End Sub
  557.  
  558. Private Sub VersionCheck()
  559. '/* operating system check
  560.  
  561. Dim tVer As OSVERSIONINFO
  562.  
  563.     With tVer
  564.         .dwVersionInfoSize = LenB(tVer)
  565.         GetVersionEx tVer
  566.         m_bIsNt = ((.dwPlatformId And VER_PLATFORM_WIN32_NT) = VER_PLATFORM_WIN32_NT)
  567.         If (.dwMajorVersion >= 5) Then
  568.             m_bIsXp = True
  569.         End If
  570.     End With
  571.  
  572. End Sub
  573.  
  574. Private Function LibraryExists(ByVal sModule As String) As Boolean
  575. '/* test for library support
  576.  
  577. Dim lhMod   As Long
  578. Dim bLoad   As Boolean
  579.  
  580.     lhMod = GetModuleHandleA(sModule)
  581.     If (lhMod = 0) Then
  582.         lhMod = LoadLibraryA(sModule)
  583.         bLoad = True
  584.     End If
  585.     If Not (lhMod = 0) Then
  586.         LibraryExists = True
  587.         If bLoad Then
  588.             FreeLibrary lhMod
  589.         End If
  590.     End If
  591.  
  592. End Function
  593.  
  594. Public Property Get GdiPlusLoaded() As Boolean
  595.     GdiPlusLoaded = m_bGdiPlusLoaded
  596. End Property
  597.  
  598. Private Function LoadGdiPlus() As Boolean
  599. '/* load gdi library
  600.  
  601. Dim tGPInput As GdiplusStartupInput
  602.  
  603. On Error GoTo Handler
  604.  
  605.     tGPInput.GdiplusVersion = 1
  606.     If (GdiplusStartup(m_lGdiPlusToken, tGPInput) = 0) Then
  607.         LoadGdiPlus = True
  608.         m_bGdiPlusLoaded = True
  609.     End If
  610.  
  611. Handler:
  612.     On Error GoTo 0
  613.     
  614. End Function
  615.  
  616. Private Sub GdiUnload()
  617. '/* unload gdi library
  618.  
  619.     If m_bGdiPlusLoaded Then
  620.         If Not (m_lGdiPlusToken = 0) Then
  621.             GdiplusShutdown m_lGdiPlusToken
  622.             m_lGdiPlusToken = 0
  623.             m_bGdiPlusLoaded = False
  624.         End If
  625.     End If
  626.     
  627. End Sub
  628.  
  629. Private Sub DrawAlphaIcon(ByVal lIndex As Long, _
  630.                           ByVal lDestDc As Long, _
  631.                           ByVal lX As Long, _
  632.                           ByVal lY As Long)
  633.  
  634. '/* could use variation of this to extract and
  635. '/* draw 32b alpha bitmaps/png also..
  636.  
  637. Dim lGraphics   As Long
  638. Dim lpBitmap    As Long
  639. Dim lhIcon      As Long
  640. Dim lHeight     As Long
  641. Dim lWidth      As Long
  642. Dim lpBmpNew    As Long
  643. Dim lFormat     As Long
  644. Dim tBmpData    As BITMAPDATA
  645. Dim tIcnInfo    As ICONINFO
  646. Dim tRect       As RECT
  647.  
  648.     '/* fetch icon handle
  649.     lhIcon = ImageList_GetIcon(m_hIml, lIndex, 1&)
  650.     '/* icon data structure
  651.     GetIconInfo lhIcon, tIcnInfo
  652.     '/* load graphics
  653.     GdipCreateFromHDC lDestDc, lGraphics
  654.     '/* copy icon bmp to a new image
  655.     GdipCreateBitmapFromHBITMAP tIcnInfo.hbmColor, 0&, lpBitmap
  656.     '/* dispose of resource
  657.     DeleteObject (tIcnInfo.hbmColor)
  658.     DeleteObject (tIcnInfo.hBmMask)
  659.     '/* get the format
  660.     GdipGetImagePixelFormat lpBitmap, lFormat
  661.     '/* not alpha
  662.     If Not (lFormat < PixelFormat32bppRGB) Then
  663.         '/* image dimensions
  664.         GdipGetImageHeight lpBitmap, lHeight
  665.         GdipGetImageWidth lpBitmap, lWidth
  666.         With tRect
  667.             .Bottom = lHeight
  668.             .left = 0
  669.             .Right = lWidth
  670.             .top = 0
  671.         End With
  672.         '/* create a new 32b bmp
  673.         GdipCreateBitmapFromScan0 lWidth, lHeight, 0&, PixelFormat32bppARGB, ByVal 0&, lpBmpNew
  674.         '/* copy 32b data structure
  675.         GdipBitmapLockBits lpBitmap, tRect, ImageLockModeRead, lFormat, tBmpData
  676.         GdipBitmapLockBits lpBmpNew, tRect, ImageLockModeWrite Or ImageLockModeUserInputBuf, PixelFormat32bppARGB, tBmpData
  677.         '/* unlock
  678.         GdipBitmapUnlockBits lpBmpNew, tBmpData
  679.         GdipBitmapUnlockBits lpBitmap, tBmpData
  680.         '/* test for alpha channel
  681.         If IsAlphaBitmap(lpBmpNew, lWidth, lHeight) Then
  682.             '/* draw the alpha image
  683.             GdipDrawImage lGraphics, lpBmpNew, lX, lY
  684.         Else
  685.             '/* draw flat image
  686.             ImageList_DrawEx m_hIml, lIndex, lDestDc, lX, lY, 0&, 0&, CLR_NONE, 0&, ILD_TRANSPARENT
  687.         End If
  688.     Else
  689.         '/* draw flat image
  690.         ImageList_DrawEx m_hIml, lIndex, lDestDc, lX, lY, 0&, 0&, CLR_NONE, 0&, ILD_TRANSPARENT
  691.     End If
  692.  
  693.     '/* cleanup
  694.     DestroyIcon lhIcon
  695.     GdipDisposeImage lpBitmap
  696.     GdipDisposeImage lpBmpNew
  697.     GdipDeleteGraphics lGraphics
  698.    
  699. End Sub
  700.  
  701. Private Function IsAlphaBitmap(ByVal lBitmap As Long, _
  702.                                ByVal lWidth As Long, _
  703.                                ByVal lHeight As Long) As Boolean
  704.  
  705. '/* if there is an alpha channel
  706. '/* colors are right shifted
  707.  
  708. Dim lY      As Long
  709. Dim lX      As Long
  710. Dim lArgb   As Long
  711.  
  712.     For lY = 0 To lHeight - 1
  713.         For lX = 0 To lWidth - 1
  714.             GdipBitmapGetPixel lBitmap, lX, lY, lArgb
  715.             If (lArgb > &HFF000000) Then
  716.                 If (lArgb < &HFFFFFFFF) Then
  717.                     IsAlphaBitmap = True
  718.                     Exit For
  719.                 End If
  720.             End If
  721.         Next lX
  722.         If IsAlphaBitmap Then
  723.             Exit For
  724.         End If
  725.     Next lY
  726.  
  727. End Function
  728.  
  729. '**********************************************************************
  730. '*                              PROPERTIES
  731. '**********************************************************************
  732.  
  733. Public Property Get ColourDepth() As EILColourDepth
  734. '/* [get] color depth
  735.     ColourDepth = m_eColourDepth
  736. End Property
  737.  
  738. Public Property Let ColourDepth(ByVal PropVal As EILColourDepth)
  739. '/* [let] color depth
  740.     If (PropVal > SystemColourDepth) Then
  741.         PropVal = SystemColourDepth
  742.     End If
  743.     If Not (PropVal = m_eColourDepth) Then
  744.         m_eColourDepth = PropVal
  745.         Create
  746.     End If
  747.     m_eColourDepth = PropVal
  748. End Property
  749.  
  750. Private Property Get SystemColourDepth() As EILColourDepth
  751. '/* [get] system color depth
  752. Dim lHdc As Long
  753.  
  754.     lHdc = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
  755.     SystemColourDepth = GetDeviceCaps(lHdc, BITSPIXEL)
  756.     DeleteDC lHdc
  757.  
  758. End Property
  759.  
  760. Public Property Get ImageCount() As Long
  761. '/* [get] image count
  762.     If Not (m_hIml = 0) Then
  763.         ImageCount = ImageList_GetImageCount(m_hIml)
  764.     End If
  765. End Property
  766.  
  767. Public Property Let ImageCount(ByVal PropVal As Long)
  768. '/* [let] dummy
  769.  
  770. End Property
  771.  
  772. Public Property Get ItemCopyOfIcon(ByVal PropVal As Variant) As Long
  773. '/* [get] copy of icon
  774. Dim lIndex As Long
  775.  
  776.     lIndex = ItemIndex(PropVal)
  777.     If Not (lIndex = -1) Then
  778.         ItemCopyOfIcon = ImageList_GetIcon(m_hIml, lIndex, ILD_TRANSPARENT)
  779.     End If
  780.  
  781. End Property
  782.  
  783. Public Property Get ItemIndex(ByVal PropVal As Variant) As Long
  784. '/* [get] icon index
  785.  
  786. Dim lResult As Long
  787.  
  788.     ItemIndex = -1
  789.     If IsNumeric(PropVal) Then
  790.         lResult = CLng(PropVal)
  791.         If (PropVal > 0) Then
  792.             If (PropVal <= ImageCount) Then
  793.                 ItemIndex = PropVal - 1
  794.             End If
  795.         End If
  796.     Else
  797.         ItemIndex = IndexFromKey(CStr(PropVal))
  798.     End If
  799.  
  800. End Property
  801.  
  802. Public Property Get ItemKey(ByVal lIndex As Long) As String
  803. '/* [get] item key
  804.     ItemKey = ""
  805.     If (lIndex > 0) Then
  806.         If (lIndex <= ImageCount) Then
  807.             ItemKey = KeyFromIndex(lIndex)
  808.         End If
  809.     End If
  810. End Property
  811.  
  812. Public Property Let ItemKey(ByVal lIndex As Long, _
  813.                             ByVal PropVal As String)
  814. '/* [let] icon key
  815.     If (lIndex > 0) Then
  816.         If (lIndex <= ImageCount) Then
  817.             AddKey lIndex, PropVal
  818.         End If
  819.     End If
  820.  
  821. End Property
  822.  
  823. Public Property Get ItemPicture(ByVal PropVal As Variant) As IPicture
  824. '/* [get] item picture
  825. Dim lIndex  As Long
  826. Dim lhIcon  As Long
  827.  
  828.     lIndex = ItemIndex(PropVal)
  829.     If Not (lIndex = -1) Then
  830.         lhIcon = ImageList_GetIcon(m_hIml, lIndex, ILD_TRANSPARENT)
  831.         If Not (lhIcon = 0) Then
  832.             Set ItemPicture = IconToPicture(lhIcon)
  833.         End If
  834.     End If
  835.  
  836. End Property
  837.  
  838. Public Property Get KeyExists(ByVal PropVal As String) As Boolean
  839. '/* [get] test item key
  840.     If (ImageCount > 0) Then
  841.         If Not (IndexFromKey(PropVal) = -1) Then
  842.             KeyExists = True
  843.         End If
  844.     End If
  845. End Property
  846.  
  847. Public Property Get hIml() As Long
  848. '/* [get] iml handle
  849.     hIml = m_hIml
  850. End Property
  851.  
  852. Public Property Get IconSizeX() As Long
  853. '/* [get] icon width
  854.     IconSizeX = m_lIconSizeX
  855. End Property
  856.  
  857. Public Property Let IconSizeX(ByVal PropVal As Long)
  858. '/* [let] icon width
  859.     If Not (PropVal = m_lIconSizeX) Then
  860.         m_lIconSizeX = PropVal
  861.         Create
  862.     End If
  863.     m_lIconSizeX = PropVal
  864. End Property
  865.  
  866. Public Property Get IconSizeY() As Long
  867. '/* [get] icon height
  868.     IconSizeY = m_lIconSizeY
  869. End Property
  870.  
  871. Public Property Let IconSizeY(ByVal PropVal As Long)
  872. '/* [let] icon height
  873.     If Not (PropVal = m_lIconSizeY) Then
  874.         m_lIconSizeY = PropVal
  875.         Create
  876.     End If
  877.     m_lIconSizeY = PropVal
  878. End Property
  879.  
  880. Public Property Get ImlName() As String
  881. '/* [get] iml name
  882.     ImlName = m_sImlName
  883. End Property
  884.  
  885. Public Property Let ImlName(ByVal PropVal As String)
  886. '/* [let] iml name
  887.     m_sImlName = PropVal
  888. End Property
  889.  
  890. Public Property Let OwnerHDC(ByVal PropVal As Long)
  891. '/* [let] owner handle
  892.     m_lOwnerDc = PropVal
  893. End Property
  894.  
  895.  
  896. '**********************************************************************
  897. '*                              SUPPORT
  898. '**********************************************************************
  899.  
  900. Public Function AddFromFile(ByVal sFileName As String, _
  901.                             ByVal eType As EILImageTypes, _
  902.                             Optional ByVal sKey As String, _
  903.                             Optional ByVal bMapSysColors As Boolean = False, _
  904.                             Optional ByVal lBackColor As OLE_COLOR = -1) As Long
  905.  
  906. Dim lhImage As Long
  907. Dim lFlags  As Long
  908.  
  909.     AddFromFile = -1
  910.     If Not (m_hIml = 0) Then
  911.         lFlags = LR_LOADFROMFILE
  912.         If bMapSysColors Then
  913.             lFlags = lFlags Or LR_LOADMAP3DCOLORS
  914.         End If
  915.         lhImage = LoadImage(App.hInstance, sFileName, eType, 0&, 0&, lFlags)
  916.         AddFromFile = AddFromHandle(lhImage, eType, sKey, lBackColor)
  917.         Select Case eType
  918.         Case IMAGE_ICON
  919.             DestroyIcon lhImage
  920.         Case IMAGE_CURSOR
  921.             DestroyCursor lhImage
  922.         Case IMAGE_BITMAP
  923.             DeleteObject lhImage
  924.         End Select
  925.     End If
  926.  
  927. End Function
  928.  
  929. Public Function AddFromHandle(ByVal lhImage As Long, _
  930.                               ByVal eType As EILImageTypes, _
  931.                               Optional ByVal sKey As String, _
  932.                               Optional ByVal lBackColor As Long = -1) As Boolean
  933.     
  934.     If Not (m_hIml = 0) Then
  935.         If Not (lhImage = 0) Then
  936.             If (eType = IMAGE_BITMAP) Then
  937.                 If (lBackColor = -1) Then
  938.                     lBackColor = GetImageBackColor(lhImage)
  939.                 End If
  940.                 ImageList_AddMasked m_hIml, lhImage, lBackColor
  941.             ElseIf (eType = IMAGE_ICON) Or (eType = IMAGE_CURSOR) Then
  942.                 ImageList_AddIcon m_hIml, lhImage
  943.             End If
  944.             If Not (Len(sKey) = 0) Then
  945.                 AddKey ImageCount, sKey
  946.             End If
  947.         End If
  948.     End If
  949.  
  950. End Function
  951.  
  952. Public Function AddFromResourceID(ByVal lID As Long, _
  953.                                   ByVal lhInst As Long, _
  954.                                   ByVal eType As EILImageTypes, _
  955.                                   Optional ByVal sKey As String, _
  956.                                   Optional ByVal bMapSysColors As Boolean = False, _
  957.                                   Optional ByVal lBackColor As Long = -1) As Long
  958.  
  959. Dim lhImage As Long
  960. Dim lFlags    As Long
  961. Dim lX     As Long
  962. Dim lY     As Long
  963.  
  964.     AddFromResourceID = -1
  965.     If Not (m_hIml = 0) Then
  966.         If bMapSysColors Then
  967.             lFlags = LR_LOADMAP3DCOLORS
  968.         End If
  969.         If Not (eType = IMAGE_BITMAP) Then
  970.             lX = m_lIconSizeX
  971.             lY = m_lIconSizeY
  972.         End If
  973.         If (lhInst = 0) Then
  974.             lFlags = lFlags Or LR_COPYRETURNORG
  975.         End If
  976.         lhImage = LoadImageLong(lhInst, lID, eType, lX, lY, lFlags)
  977.         AddFromResourceID = AddFromHandle(lhImage, eType, sKey, lBackColor)
  978.         Select Case eType
  979.         Case IMAGE_ICON
  980.             DestroyIcon lhImage
  981.         Case IMAGE_CURSOR
  982.             DestroyCursor lhImage
  983.         Case IMAGE_BITMAP
  984.             DeleteObject lhImage
  985.         End Select
  986.     End If
  987.  
  988. End Function
  989.  
  990. Public Function BitmapToPicture(ByVal lhBmp As Long) As IPicture
  991.  
  992. Dim NewPic   As Picture
  993. Dim tPicConv As PictDesc
  994. Dim IGuid    As Guid
  995.  
  996.     If Not (lhBmp = 0) Then
  997.         With tPicConv
  998.             .cbSizeofStruct = Len(tPicConv)
  999.             .picType = vbPicTypeBitmap
  1000.             .hImage = lhBmp
  1001.         End With
  1002.         With IGuid
  1003.             .Data1 = &H20400
  1004.             .Data4(0) = &HC0
  1005.             .Data4(7) = &H46
  1006.         End With
  1007.         OleCreatePictureIndirect tPicConv, IGuid, True, NewPic
  1008.         Set BitmapToPicture = NewPic
  1009.     End If
  1010.  
  1011. End Function
  1012.  
  1013. Public Sub Clear()
  1014.     Create
  1015.     Set m_cKeys = Nothing
  1016.     Set m_cKeys = New Collection
  1017. End Sub
  1018.  
  1019. Public Function Create() As Boolean
  1020.  
  1021.     Destroy
  1022.     m_hIml = ImageList_Create(m_lIconSizeX, m_lIconSizeY, ILC_MASK Or m_eColourDepth, 4&, 4&)
  1023.     If Not (m_hIml = 0) Then
  1024.         If Not (m_hIml = -1) Then
  1025.             Create = True
  1026.         End If
  1027.     End If
  1028.  
  1029. End Function
  1030.  
  1031. Public Sub Destroy()
  1032.  
  1033.     If Not (m_hIml = 0) Then
  1034.         ImageList_Destroy m_hIml
  1035.         m_hIml = 0
  1036.     End If
  1037.  
  1038. End Sub
  1039.  
  1040. Public Sub DrawImage(ByVal lHdc As Long, _
  1041.                      ByVal lIndex As Long, _
  1042.                      ByVal lX As Long, _
  1043.                      ByVal lY As Long, _
  1044.                      Optional ByVal eState As EILDrawState = ildNormal, _
  1045.                      Optional ByVal lDither As Long = vbWindowBackground)
  1046.  
  1047. Dim lhIcon     As Long
  1048. Dim lFlags    As Long
  1049. Dim lColor    As Long
  1050.  
  1051.     If (lIndex > -1) Then
  1052.         If Not (m_hIml = 0) Then
  1053.             lFlags = ILD_TRANSPARENT
  1054.             Select Case eState
  1055.             Case ildColored
  1056.                 lFlags = lFlags Or ILD_BLEND25
  1057.                 lColor = TranslateColor(lDither)
  1058.                 ImageList_DrawEx m_hIml, lIndex, lHdc, lX, lY, 0&, 0&, CLR_NONE, lColor, lFlags
  1059.             Case ildCutDisabled
  1060.                 lColor = GetSysColor(COLOR_WINDOW)
  1061.                 lFlags = lFlags Or ILD_SELECTED
  1062.                 ImageList_DrawEx m_hIml, lIndex, lHdc, lX, lY, 0&, 0&, CLR_NONE, lColor, lFlags
  1063.             Case ildDisabled
  1064.                 lhIcon = ImageList_GetIcon(m_hIml, lIndex, 0&)
  1065.                 DrawState lHdc, 0&, 0&, lhIcon, 0&, lX, lY, m_lIconSizeX, m_lIconSizeY, DST_ICON Or DSS_DISABLED
  1066.                 DestroyIcon lhIcon
  1067.             Case ildSelected
  1068.                 lFlags = lFlags Or ILD_SELECTED
  1069.                 ImageList_DrawEx m_hIml, lIndex, lHdc, lX, lY, 0&, 0&, CLR_NONE, 0&, lFlags
  1070.             Case Else
  1071.                 If (m_eColourDepth = ILC_COLOR32) Then
  1072.                     If m_bGdiPlusLoaded Then
  1073.                         DrawAlphaIcon lIndex, lHdc, lX, lY
  1074.                     Else
  1075.                         ImageList_DrawEx m_hIml, lIndex, lHdc, lX, lY, 0&, 0&, CLR_NONE, 0&, ILD_TRANSPARENT
  1076.                     End If
  1077.                 Else
  1078.                     ImageList_DrawEx m_hIml, lIndex, lHdc, lX, lY, 0&, 0&, CLR_NONE, 0&, ILD_TRANSPARENT
  1079.                 End If
  1080.             End Select
  1081.         End If
  1082.     End If
  1083.  
  1084. End Sub
  1085.  
  1086. Public Function IconToPicture(ByVal lhIcon As Long) As IPicture
  1087.  
  1088. Dim NewPic  As Picture
  1089. Dim PicConv As PictDesc
  1090. Dim IGuid   As Guid
  1091.  
  1092.     If Not (lhIcon = 0) Then
  1093.         With PicConv
  1094.             .cbSizeofStruct = Len(PicConv)
  1095.             .picType = vbPicTypeIcon
  1096.             .hImage = lhIcon
  1097.         End With
  1098.         With IGuid
  1099.             .Data1 = &H7BF80980
  1100.             .Data2 = &HBF32
  1101.             .Data3 = &H101A
  1102.             .Data4(0) = &H8B
  1103.             .Data4(1) = &HBB
  1104.             .Data4(2) = &H0
  1105.             .Data4(3) = &HAA
  1106.             .Data4(4) = &H0
  1107.             .Data4(5) = &H30
  1108.             .Data4(6) = &HC
  1109.             .Data4(7) = &HAB
  1110.         End With
  1111.         OleCreatePictureIndirect PicConv, IGuid, True, NewPic
  1112.         Set IconToPicture = NewPic
  1113.     End If
  1114.  
  1115. End Function
  1116.  
  1117. Public Sub RemoveImage(ByVal vKey As Variant)
  1118.  
  1119. Dim lIndex  As Long
  1120.  
  1121.     If Not (m_hIml = 0) Then
  1122.         If IsNumeric(vKey) Then
  1123.             lIndex = vKey
  1124.             If (lIndex > -1) Then
  1125.                 ImageList_Remove m_hIml, lIndex
  1126.                 RemoveKey lIndex
  1127.             End If
  1128.         Else
  1129.             lIndex = IndexFromKey(CStr(vKey))
  1130.             If (lIndex > -1) Then
  1131.                 ImageList_Remove m_hIml, lIndex
  1132.                 RemoveKey lIndex
  1133.             End If
  1134.         End If
  1135.     End If
  1136.  
  1137. End Sub
  1138.  
  1139. Private Sub AddKey(ByVal lIndex As Long, _
  1140.                    ByVal sKey As String)
  1141.  
  1142. On Error Resume Next
  1143.  
  1144.     With m_cKeys
  1145.         If (.Item(lIndex)) Then
  1146.             .Remove (lIndex)
  1147.         End If
  1148.         .Add lIndex, sKey
  1149.     End With
  1150.     
  1151. On Error GoTo 0
  1152.  
  1153. End Sub
  1154.  
  1155. Public Function IndexFromKey(ByVal sKey As String) As Long
  1156.  
  1157. On Error Resume Next
  1158.  
  1159.     IndexFromKey = m_cKeys.Item(sKey)
  1160.     If Not (Err.Number = 0) Then
  1161.         IndexFromKey = -1
  1162.     End If
  1163.     
  1164. On Error GoTo 0
  1165.  
  1166. End Function
  1167.  
  1168. Public Function KeyFromIndex(ByVal lIndex As Long) As String
  1169.  
  1170. On Error Resume Next
  1171.  
  1172.     KeyFromIndex = FetchItemKey(lIndex, m_cKeys)
  1173.     
  1174. On Error GoTo 0
  1175.  
  1176. End Function
  1177.  
  1178. Private Sub RemoveKey(ByVal lIndex As Long)
  1179.  
  1180. On Error Resume Next
  1181.  
  1182.     m_cKeys.Remove lIndex
  1183.     
  1184. On Error GoTo 0
  1185.  
  1186. End Sub
  1187.  
  1188. Public Sub SwapOrCopyImage(ByVal lSrcIcon As Long, _
  1189.                            ByVal lDstIcon As Long, _
  1190.                            Optional ByVal eSwap As EILSwapTypes = ilsSwap)
  1191.  
  1192. Dim lDst    As Long
  1193. Dim lSrc    As Long
  1194. Dim sKeyDst As String
  1195. Dim sKeySrc As String
  1196.  
  1197.     If Not (m_hIml = 0) Then
  1198.         lDst = ItemIndex(lSrcIcon)
  1199.         If lDst > -1 Then
  1200.             lSrc = ItemIndex(lDstIcon)
  1201.             If lSrc > -1 Then
  1202.                 ImageList_Copy m_hIml, lDst, m_hIml, lSrc, eSwap
  1203.                 sKeySrc = KeyFromIndex(lSrcIcon)
  1204.                 sKeyDst = KeyFromIndex(lDstIcon)
  1205.                 If Not (Len(sKeySrc) = 0) Then
  1206.                     AddKey lDstIcon, sKeySrc
  1207.                 End If
  1208.                 If Not (Len(sKeyDst) = 0) Then
  1209.                     AddKey lSrcIcon, sKeyDst
  1210.                 End If
  1211.             End If
  1212.         End If
  1213.     End If
  1214.  
  1215. End Sub
  1216.  
  1217. Private Function FetchItemKey(ByVal lIndex As Long, _
  1218.                               ByRef cCol As Collection) As String
  1219.  
  1220. Dim lCt     As Long
  1221. Dim lPtr    As Long
  1222. Dim sKey    As String
  1223.  
  1224.     If Not (cCol Is Nothing) Then
  1225.         If Not (lIndex < 1) Then
  1226.             If Not (lIndex > cCol.Count) Then
  1227.                 Select Case lIndex
  1228.                 Case Is <= cCol.Count / 2
  1229.                     RtlMoveMemory lPtr, ByVal ObjPtr(cCol) + 24, 4&
  1230.                     For lCt = 2 To lIndex
  1231.                         RtlMoveMemory lPtr, ByVal lPtr + 24, 4&
  1232.                     Next lCt
  1233.                 Case Else
  1234.                     RtlMoveMemory lPtr, ByVal ObjPtr(cCol) + 28, 4&
  1235.                     For lCt = cCol.Count - 1 To lIndex Step -1
  1236.                         RtlMoveMemory lPtr, ByVal lPtr + 20, 4&
  1237.                     Next lCt
  1238.                 End Select
  1239.                 lCt = StrPtr(sKey)
  1240.                 RtlMoveMemory ByVal VarPtr(sKey), ByVal lPtr + 16, 4&
  1241.                 FetchItemKey = sKey
  1242.                 RtlMoveMemory ByVal VarPtr(sKey), lCt, 4&
  1243.             End If
  1244.         End If
  1245.     End If
  1246.  
  1247. End Function
  1248.  
  1249. Public Function TranslateColor(ByVal clr As OLE_COLOR, _
  1250.                                 Optional hpal As Long = 0) As Long
  1251.  
  1252.     If OleTranslateColor(clr, hpal, TranslateColor) Then
  1253.         TranslateColor = CLR_INVALID
  1254.     End If
  1255.  
  1256. End Function
  1257.  
  1258. Private Function GetImageBackColor(ByVal lhImage As Long) As Long
  1259.  
  1260. Dim lHdc    As Long
  1261. Dim lTmpDc  As Long
  1262. Dim lhBmp   As Long
  1263.  
  1264.     lTmpDc = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
  1265.     If Not (lTmpDc = 0) Then
  1266.         lHdc = CreateCompatibleDC(lTmpDc)
  1267.         DeleteDC lTmpDc
  1268.         If Not (lHdc = 0) Then
  1269.             lhBmp = SelectObject(lHdc, lhImage)
  1270.             If Not (lhBmp = 0) Then
  1271.                 GetImageBackColor = GetPixel(lHdc, 0&, 0&)
  1272.                 SelectObject lHdc, lhBmp
  1273.             End If
  1274.             DeleteObject lHdc
  1275.         End If
  1276.     End If
  1277.                         
  1278. End Function
  1279.  
  1280.  
  1281. '**********************************************************************
  1282. '*                              SYSTEM IML
  1283. '**********************************************************************
  1284.  
  1285. Public Property Get SystemImlHandle(ByVal sFile As String, _
  1286.                                     ByVal eIconSize As EISIconSize) As Long
  1287.  
  1288. Dim lHandle As Long
  1289. Dim tFI     As SHFILEINFOA
  1290.  
  1291.     SystemImlHandle = -1
  1292.     If Not (Len(sFile) = 0) Then
  1293.         lHandle = SHGetFileInfoA(sFile, FILE_ATTRIBUTE_NORMAL, tFI, LenB(tFI), ICON_FLAGS Or eIconSize)
  1294.         If Not (lHandle = 0) Then
  1295.             SystemImlHandle = lHandle
  1296.         End If
  1297.     End If
  1298.  
  1299. End Property
  1300.  
  1301. Public Function SystemIconIndex(ByVal sFile As String, _
  1302.                                 ByVal eIconSize As EISIconSize) As Long
  1303.  
  1304. Dim lFlags  As Long
  1305. Dim lResult As Long
  1306.  
  1307.     SystemIconIndex = -1
  1308.     lFlags = SHGFI_SYSICONINDEX Or SHGFI_USEFILEATTRIBUTES Or eIconSize
  1309.     
  1310.     If m_bIsNt Then
  1311.         If Not (LenB(sFile) = 0) Then
  1312.             Dim tFW As SHFILEINFOW
  1313.             lResult = SHGetFileInfoW(StrPtr(sFile), FILE_ATTRIBUTE_NORMAL, tFW, Len(tFW), lFlags)
  1314.             If Not (lResult = 0) Then
  1315.                 SystemIconIndex = tFW.iIcon
  1316.             End If
  1317.         End If
  1318.     Else
  1319.         If Not (Len(sFile) = 0) Then
  1320.             Dim tFA As SHFILEINFOA
  1321.             lResult = SHGetFileInfoA(sFile, FILE_ATTRIBUTE_NORMAL, tFA, Len(tFA), lFlags)
  1322.             If Not (lResult = 0) Then
  1323.                 SystemIconIndex = tFA.iIcon
  1324.             End If
  1325.         End If
  1326.     End If
  1327.  
  1328. End Function
  1329.  
  1330. Public Function SystemIconHandle(ByVal sFile As String, _
  1331.                                  ByVal eIconSize As EISIconSize) As Long
  1332.  
  1333. Dim lFlags  As Long
  1334. Dim lResult As Long
  1335.  
  1336.     SystemIconHandle = -1
  1337.     lFlags = SHGFI_ICON Or SHGFI_USEFILEATTRIBUTES Or eIconSize
  1338.     
  1339.     If m_bIsNt Then
  1340.         If Not (Len(sFile) = 0) Then
  1341.             Dim tFW As SHFILEINFOW
  1342.             lResult = SHGetFileInfoW(StrPtr(sFile), FILE_ATTRIBUTE_NORMAL, tFW, Len(tFW), lFlags)
  1343.             If Not (lResult = 0) Then
  1344.                 SystemIconHandle = tFW.hicon
  1345.             End If
  1346.         End If
  1347.     Else
  1348.         If Not (Len(sFile) = 0) Then
  1349.             Dim tFA As SHFILEINFOA
  1350.             lResult = SHGetFileInfoA(sFile, FILE_ATTRIBUTE_NORMAL, tFA, Len(tFA), lFlags)
  1351.             If Not (lResult = 0) Then
  1352.                 SystemIconHandle = tFA.hicon
  1353.             End If
  1354.         End If
  1355.     End If
  1356.    
  1357. End Function
  1358.  
  1359.  
  1360. '**********************************************************************
  1361. '*                              SAVE/RESTORE
  1362. '**********************************************************************
  1363.  
  1364. Private Sub SaveKeys(ByRef bKeys() As Byte)
  1365.  
  1366. Dim lItem As Long
  1367. Dim sKeys As String
  1368.  
  1369.     If (m_cKeys.Count > 0) Then
  1370.         For lItem = 1 To m_cKeys.Count
  1371.             sKeys = sKeys & lItem & ItemKey(lItem) & Chr$(30)
  1372.         Next lItem
  1373.         sKeys = left$(sKeys, Len(sKeys) - 1)
  1374.         bKeys = sKeys
  1375.     End If
  1376.     
  1377. End Sub
  1378.  
  1379. Private Sub LoadKeys(ByRef bKeys() As Byte)
  1380.  
  1381. Dim lItem   As Long
  1382. Dim sKeys   As String
  1383. Dim aKeys() As String
  1384.  
  1385.     If (UBound(bKeys) > 0) Then
  1386.         sKeys = bKeys
  1387.         aKeys = Split(sKeys, Chr$(30))
  1388.         For lItem = 0 To UBound(aKeys)
  1389.             m_cKeys.Add left$(aKeys(lItem), 1), Mid$(aKeys(lItem), 2)
  1390.         Next lItem
  1391.     End If
  1392.     
  1393. End Sub
  1394.  
  1395. Public Sub SaveIcons(ByRef bKeys() As Byte, _
  1396.                      ByRef bIcons() As Byte)
  1397.  
  1398. Dim lCt     As Long
  1399. Dim lSize   As Long
  1400. Dim lStart  As Long
  1401. Dim lhIcon  As Long
  1402. Dim lHdc    As Long
  1403.  
  1404.     If (m_hIml > 0) Then
  1405.         If (ImageCount > -1) Then
  1406.             If (IconSizeX > 48) Then '<- 72x 32b icons can be past 16k boundary causing hang and gpf
  1407.                 ReDim bIcons(0 To 32768 * ImageCount) As Byte
  1408.             Else
  1409.                 ReDim bIcons(0 To 16384& * ImageCount) As Byte
  1410.             End If
  1411.             lHdc = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
  1412.             For lCt = 1 To ImageCount
  1413.                 lhIcon = ImageList_GetIcon(m_hIml, lCt - 1, 0&)
  1414.                 If Not (lhIcon = 0) Then
  1415.                     If Not (lhIcon = -1) Then
  1416.                         SerialiseIcon lHdc, lhIcon, bIcons, lStart, lSize
  1417.                         DestroyIcon lhIcon
  1418.                     End If
  1419.                 End If
  1420.                 lStart = lStart + lSize
  1421.             Next lCt
  1422.             DeleteDC lHdc
  1423.         End If
  1424.     End If
  1425.     SaveKeys bKeys
  1426.  
  1427. End Sub
  1428.  
  1429. Public Function SerialiseIcon(ByVal lHdc As Long, _
  1430.                               ByVal lhIcon As Long, _
  1431.                               ByRef b() As Byte, _
  1432.                               ByVal lByteStart As Long, _
  1433.                               ByRef lArraySize As Long) As Boolean
  1434.  
  1435. Dim lR              As Long
  1436. Dim lMonoSize       As Long
  1437. Dim lColourSize     As Long
  1438. Dim tII             As ICONINFO
  1439.  
  1440.     lR = GetIconInfo(lhIcon, tII)
  1441.     If Not (lR = 0) Then
  1442.         ' store fIcon, xHotspot, yHotspot:
  1443.         RtlMoveMemory b(lByteStart), tII, 12
  1444.         ' store the colour bitmap:
  1445.         lByteStart = lByteStart + 12
  1446.         With tII
  1447.             If (SerialiseBitmap(lHdc, .hbmColor, False, b(), lByteStart, lColourSize)) Then
  1448.                 lByteStart = lByteStart + lColourSize
  1449.                 If (SerialiseBitmap(lHdc, .hBmMask, True, b(), lByteStart, lMonoSize)) Then
  1450.                     lByteStart = lByteStart + lMonoSize
  1451.                     lArraySize = lColourSize + lMonoSize + 12
  1452.                     SerialiseIcon = True
  1453.                 End If
  1454.             End If
  1455.             DeleteObject .hbmColor
  1456.             DeleteObject .hBmMask
  1457.         End With
  1458.     End If
  1459.  
  1460. End Function
  1461.  
  1462. Private Function SerialiseBitmap(ByVal lHdc As Long, _
  1463.                                  ByVal hbm As Long, _
  1464.                                  ByVal bMono As Boolean, _
  1465.                                  ByRef b() As Byte, _
  1466.                                  ByVal lByteStart As Long, _
  1467.                                  ByRef lByteSize As Long) As Boolean
  1468.  
  1469. Dim lSize   As Long
  1470. Dim lR      As Long
  1471. Dim tBM     As bitmap
  1472. Dim tBI1    As BITMAPINFO_1BPP
  1473. Dim tBI     As BITMAPINFO_ABOVE8
  1474.  
  1475.     lR = GetObjectAPI(hbm, Len(tBM), tBM)
  1476.     If Not (lR = 0) Then
  1477.         RtlMoveMemory b(lByteStart), tBM, Len(tBM)
  1478.         If (bMono) Then
  1479.             With tBI1.bmiHeader
  1480.                 .biSize = Len(tBI1.bmiHeader)
  1481.                 .biWidth = tBM.bmWidth
  1482.                 .biHeight = tBM.bmHeight
  1483.                 .biPlanes = 1
  1484.                 .biBitCount = 1
  1485.                 .biCompression = BI_RGB
  1486.                 lSize = (.biWidth + 7) / 8
  1487.                 lSize = ((lSize + 3) \ 4) * 4
  1488.                 lSize = lSize * .biHeight
  1489.             End With
  1490.             lR = GetDIBits(lHdc, hbm, 0&, tBM.bmHeight, b(lByteStart + Len(tBM)), tBI1, DIB_RGB_COLORS)
  1491.           Else
  1492.             With tBI.bmiHeader
  1493.                 .biSize = Len(tBI.bmiHeader)
  1494.                 .biWidth = tBM.bmWidth
  1495.                 .biHeight = tBM.bmHeight
  1496.                 .biPlanes = 1
  1497.                 .biBitCount = 24
  1498.                 .biCompression = BI_RGB
  1499.                 .biBitCount = 32
  1500.                 lSize = .biWidth * .biHeight * 4
  1501.             End With
  1502.             lR = GetDIBits(lHdc, hbm, 0, tBM.bmHeight, b(lByteStart + Len(tBM)), tBI, DIB_RGB_COLORS)
  1503.         End If
  1504.         If Not (lR = 0) Then
  1505.             lByteSize = lSize + Len(tBM)
  1506.             SerialiseBitmap = True
  1507.         End If
  1508.     End If
  1509.  
  1510. End Function
  1511.  
  1512. Public Function RestoreIcons(ByRef bKeys() As Byte, _
  1513.                              ByRef bIcons() As Byte)
  1514.  
  1515. Dim lSize       As Long
  1516. Dim lStart      As Long
  1517. Dim lItemSize   As Long
  1518. Dim lhIcon      As Long
  1519. Dim lHdc        As Long
  1520.  
  1521.     lSize = UBound(bIcons)
  1522.     If (lSize > 0) Then
  1523.         lHdc = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
  1524.         Do While lStart < lSize
  1525.             If (DeSerialiseIcon(lHdc, lhIcon, bIcons, lStart, lItemSize)) Then
  1526.                 ImageList_AddIcon m_hIml, lhIcon
  1527.                 DestroyIcon lhIcon
  1528.             End If
  1529.             lStart = lStart + lItemSize
  1530.         Loop
  1531.         DeleteDC lHdc
  1532.         Erase bIcons
  1533.     End If
  1534.     LoadKeys bKeys
  1535.     
  1536. End Function
  1537.  
  1538. Public Function DeSerialiseIcon(ByVal lHdc As Long, _
  1539.                                 ByRef lhIcon As Long, _
  1540.                                 ByRef b() As Byte, _
  1541.                                 ByVal lByteStart As Long, _
  1542.                                 ByRef lArraySize As Long)
  1543.  
  1544. Dim lColourSize     As Long
  1545. Dim lMonoSize       As Long
  1546. Dim tII             As ICONINFO
  1547.  
  1548.     lhIcon = 0
  1549.     ' get fIcon, xHotspot, yHotspot:
  1550.     RtlMoveMemory tII, b(lByteStart), 12
  1551.     With tII
  1552.         .fIcon = 1
  1553.         lByteStart = lByteStart + 12
  1554.         ' get the colour bitmap:
  1555.         If (DeSerialiseBitmap(lHdc, .hbmColor, False, b(), lByteStart, lColourSize)) Then
  1556.             lByteStart = lByteStart + lColourSize
  1557.             ' get the mono bitmap:
  1558.             If (DeSerialiseBitmap(lHdc, .hBmMask, True, b(), lByteStart, lMonoSize)) Then
  1559.                 ' Set the size:
  1560.                 lArraySize = lColourSize + lMonoSize + 12
  1561.                 ' Create the icon from the structure:
  1562.                 lhIcon = CreateIconIndirect(tII)
  1563.                 DeSerialiseIcon = (lhIcon <> 0)
  1564.                 DeleteObject .hbmColor
  1565.                 DeleteObject .hBmMask
  1566.             Else
  1567.                 DeleteObject .hbmColor
  1568.             End If
  1569.         End If
  1570.     End With
  1571.  
  1572. End Function
  1573.  
  1574. Private Function DeSerialiseBitmap(ByVal lHdc As Long, _
  1575.                                    ByRef hbm As Long, _
  1576.                                    ByVal bMono As Boolean, _
  1577.                                    ByRef b() As Byte, _
  1578.                                    ByVal lByteStart As Long, _
  1579.                                    ByRef lByteSize As Long) As Boolean
  1580.  
  1581. Dim lSize   As Long
  1582. Dim lR      As Long
  1583. Dim tBM     As bitmap
  1584. Dim tBI1    As BITMAPINFO_1BPP
  1585. Dim tBI     As BITMAPINFO_ABOVE8
  1586.  
  1587.     RtlMoveMemory tBM, b(lByteStart), Len(tBM)
  1588.     If Not (bMono) Then
  1589.         hbm = CreateCompatibleBitmap(lHdc, tBM.bmWidth, tBM.bmHeight)
  1590.       Else
  1591.         hbm = CreateBitmapIndirect(tBM)
  1592.     End If
  1593.     If Not (hbm = 0) Then
  1594.         If (bMono) Then
  1595.             With tBI1.bmiHeader
  1596.                 .biSize = Len(tBI1.bmiHeader)
  1597.                 .biWidth = tBM.bmWidth
  1598.                 .biHeight = tBM.bmHeight
  1599.                 .biPlanes = 1
  1600.                 .biBitCount = 1
  1601.                 .biCompression = BI_RGB
  1602.             End With
  1603.             With tBI1
  1604.                 lSize = (.bmiHeader.biWidth + 7) / 8
  1605.                 lSize = ((lSize + 3) \ 4) * 4
  1606.                 lSize = lSize * .bmiHeader.biHeight
  1607.                 .bmiColors(1).rgbBlue = 255
  1608.                 .bmiColors(1).rgbGreen = 255
  1609.                 .bmiColors(1).rgbRed = 255
  1610.             End With
  1611.             lR = SetDIBits(lHdc, hbm, 0, tBM.bmHeight, b(lByteStart + Len(tBM)), tBI1, DIB_RGB_COLORS)
  1612.         Else
  1613.             With tBI.bmiHeader
  1614.                 .biSize = Len(tBI.bmiHeader)
  1615.                 .biWidth = tBM.bmWidth
  1616.                 .biHeight = tBM.bmHeight
  1617.                 .biPlanes = 1
  1618.                 .biBitCount = 24
  1619.                 .biCompression = BI_RGB
  1620.                 .biBitCount = 32
  1621.                 lSize = .biWidth * .biHeight * 4
  1622.             End With
  1623.             lR = SetDIBits(lHdc, hbm, 0, tBM.bmHeight, b(lByteStart + Len(tBM)), tBI, DIB_RGB_COLORS)
  1624.         End If
  1625.  
  1626.         lByteSize = lSize + Len(tBM)
  1627.         If Not (lR = 0) Then
  1628.             DeSerialiseBitmap = True
  1629.           Else
  1630.             DeleteObject hbm
  1631.         End If
  1632.     End If
  1633.  
  1634. End Function
  1635.  
  1636. Private Sub Class_Terminate()
  1637.     Destroy
  1638.     GdiUnload
  1639. End Sub
  1640.  
  1641.