home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / TButton2147383222009.psc / cVBALImageList.cls < prev   
Text File  |  2009-03-22  |  42KB  |  1,129 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 = "cVBALImageList"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' =========================================================================
  17. ' vbAccelerator Image List Control Demonstrator
  18. ' Copyright ⌐ 1998 Steve McMahon (steve@dogma.demon.co.uk)
  19. '
  20. ' Implements an Image List control in VB using COMCTL32.DLL
  21. '
  22. ' Visit vbAccelerator at www.dogma.demon.co.uk
  23. ' =========================================================================
  24.  
  25. ' -----------
  26. ' API
  27. ' -----------
  28. ' General:
  29. Private Declare Function GetWindowWord Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long) As Integer
  30.     Private Const GWW_HINSTANCE = (-6)
  31.     
  32. ' GDI object functions:
  33. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  34. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  35. Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
  36. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  37. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  38. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  39. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  40. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  41. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  42. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
  43.     Private Const BITSPIXEL = 12
  44.     Private Const LOGPIXELSX = 88    '  Logical pixels/inch in X
  45.     Private Const LOGPIXELSY = 90    '  Logical pixels/inch in Y
  46. ' System metrics:
  47. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  48.     Private Const SM_CXICON = 11
  49.     Private Const SM_CYICON = 12
  50.     Private Const SM_CXFRAME = 32
  51.     Private Const SM_CYCAPTION = 4
  52.     Private Const SM_CYFRAME = 33
  53.     Private Const SM_CYBORDER = 6
  54.     Private Const SM_CXBORDER = 5
  55.  
  56. ' Region paint and fill functions:
  57. Private Declare Function PaintRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
  58. 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
  59.     Private Const FLOODFILLBORDER = 0
  60.     Private Const FLOODFILLSURFACE = 1
  61. Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  62.  
  63. ' Pen functions:
  64. Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  65.     Private Const PS_DASH = 1
  66.     Private Const PS_DASHDOT = 3
  67.     Private Const PS_DASHDOTDOT = 4
  68.     Private Const PS_DOT = 2
  69.     Private Const PS_SOLID = 0
  70.     Private Const PS_NULL = 5
  71.  
  72. ' Brush functions:
  73. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  74. Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
  75.  
  76. ' Line functions:
  77. Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  78. Private Type POINTAPI
  79.    x As Long
  80.    y As Long
  81. End Type
  82. Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
  83.  
  84. ' Colour functions:
  85. Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  86. Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  87. Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
  88.     Private Const OPAQUE = 2
  89.     Private Const TRANSPARENT = 1
  90. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  91.     Private Const COLOR_ACTIVEBORDER = 10
  92.     Private Const COLOR_ACTIVECAPTION = 2
  93.     Private Const COLOR_ADJ_MAX = 100
  94.     Private Const COLOR_ADJ_MIN = -100
  95.     Private Const COLOR_APPWORKSPACE = 12
  96.     Private Const COLOR_BACKGROUND = 1
  97.     Private Const COLOR_BTNFACE = 15
  98.     Private Const COLOR_BTNHIGHLIGHT = 20
  99.     Private Const COLOR_BTNSHADOW = 16
  100.     Private Const COLOR_BTNTEXT = 18
  101.     Private Const COLOR_CAPTIONTEXT = 9
  102.     Private Const COLOR_GRAYTEXT = 17
  103.     Private Const COLOR_HIGHLIGHT = 13
  104.     Private Const COLOR_HIGHLIGHTTEXT = 14
  105.     Private Const COLOR_INACTIVEBORDER = 11
  106.     Private Const COLOR_INACTIVECAPTION = 3
  107.     Private Const COLOR_INACTIVECAPTIONTEXT = 19
  108.     Private Const COLOR_MENU = 4
  109.     Private Const COLOR_MENUTEXT = 7
  110.     Private Const COLOR_SCROLLBAR = 0
  111.     Private Const COLOR_WINDOW = 5
  112.     Private Const COLOR_WINDOWFRAME = 6
  113.     Private Const COLOR_WINDOWTEXT = 8
  114.     Private Const COLORONCOLOR = 3
  115.  
  116. ' Shell Extract icon functions:
  117. Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
  118. Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
  119.  
  120. ' Icon functions:
  121. Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
  122. Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
  123. 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
  124. 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
  125. 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
  126.     Private Const LR_LOADMAP3DCOLORS = &H1000
  127.     Private Const LR_LOADFROMFILE = &H10
  128.     Private Const LR_LOADTRANSPARENT = &H20
  129.     Private Const LR_COPYRETURNORG = &H4
  130.  
  131. ' Blitting functions
  132. 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
  133.     Private Const SRCAND = &H8800C6
  134.     Private Const SRCCOPY = &HCC0020
  135.     Private Const SRCERASE = &H440328
  136.     Private Const SRCINVERT = &H660046
  137.     Private Const SRCPAINT = &HEE0086
  138.     Private Const BLACKNESS = &H42
  139.     Private Const WHITENESS = &HFF0062
  140. 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
  141. Private Declare Function LoadBitmapBynum Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As Long) As Long
  142. Private Type BITMAP '14 bytes
  143.     bmType As Long
  144.     bmWidth As Long
  145.     bmHeight As Long
  146.     bmWidthBytes As Long
  147.     bmPlanes As Integer
  148.     bmBitsPixel As Integer
  149.     bmBits As Long
  150. End Type
  151. Private Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As BITMAP) As Long
  152.  
  153. ' Text functions:
  154. Private Type RECT
  155.     left As Long
  156.     tOp As Long
  157.     Right As Long
  158.     Bottom As Long
  159. End Type
  160. Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptX As Long, ByVal ptY As Long) As Long
  161. 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
  162.     Private Const DT_BOTTOM = &H8&
  163.     Private Const DT_CENTER = &H1&
  164.     Private Const DT_LEFT = &H0&
  165.     Private Const DT_CALCRECT = &H400&
  166.     Private Const DT_WORDBREAK = &H10&
  167.     Private Const DT_VCENTER = &H4&
  168.     Private Const DT_TOP = &H0&
  169.     Private Const DT_TABSTOP = &H80&
  170.     Private Const DT_SINGLELINE = &H20&
  171.     Private Const DT_RIGHT = &H2&
  172.     Private Const DT_NOCLIP = &H100&
  173.     Private Const DT_INTERNAL = &H1000&
  174.     Private Const DT_EXTERNALLEADING = &H200&
  175.     Private Const DT_EXPANDTABS = &H40&
  176.     Private Const DT_CHARSTREAM = 4&
  177.     Private Const DT_NOPREFIX = &H800&
  178. Private Type DRAWTEXTPARAMS
  179.     cbSize As Long
  180.     iTabLength As Long
  181.     iLeftMargin As Long
  182.     iRightMargin As Long
  183.     uiLengthDrawn As Long
  184. End Type
  185. 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
  186. 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
  187.     Private Const DT_EDITCONTROL = &H2000&
  188.     Private Const DT_PATH_ELLIPSIS = &H4000&
  189.     Private Const DT_END_ELLIPSIS = &H8000&
  190.     Private Const DT_MODIFYSTRING = &H10000
  191.     Private Const DT_RTLREADING = &H20000
  192.     Private Const DT_WORD_ELLIPSIS = &H40000
  193.  
  194. Private Type SIZEAPI
  195.     cX As Long
  196.     cY As Long
  197. End Type
  198. 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
  199. Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
  200.     Private Const ANSI_FIXED_FONT = 11
  201.     Private Const ANSI_VAR_FONT = 12
  202.     Private Const SYSTEM_FONT = 13
  203.     Private Const DEFAULT_GUI_FONT = 17 'win95 only
  204. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  205. 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
  206. Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal Edge As Long, ByVal grfFlags As Long) As Long
  207.     Private Const BF_LEFT = 1
  208.     Private Const BF_TOP = 2
  209.     Private Const BF_RIGHT = 4
  210.     Private Const BF_BOTTOM = 8
  211.     Private Const BF_RECT = BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM
  212.     Private Const BF_MIDDLE = 2048
  213.     Private Const BDR_SUNKENINNER = 8
  214.     Private Const BDR_SUNKENOUTER = 2
  215.     Private Const BDR_RAISEDOUTER = 1
  216.     Private Const BDR_RAISEDINNER = 4
  217.  
  218. Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
  219.     Private Const SW_SHOWNOACTIVATE = 4
  220.  
  221. ' Scrolling and region functions:
  222. 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
  223. Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
  224. Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
  225. Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
  226. Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
  227. Private Declare Function CreatePolyPolygonRgn Lib "gdi32" (lpPoint As POINTAPI, lpPolyCounts As Long, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
  228. Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long)
  229. Private Declare Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long
  230. Private Declare Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal hSavedDC As Long) As Long
  231. Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
  232.  
  233. Private Const LF_FACESIZE = 32
  234. Private Type LOGFONT
  235.     lfHeight As Long
  236.     lfWidth As Long
  237.     lfEscapement As Long
  238.     lfOrientation As Long
  239.     lfWeight As Long
  240.     lfItalic As Byte
  241.     lfUnderline As Byte
  242.     lfStrikeOut As Byte
  243.     lfCharSet As Byte
  244.     lfOutPrecision As Byte
  245.     lfClipPrecision As Byte
  246.     lfQuality As Byte
  247.     lfPitchAndFamily As Byte
  248.     lfFaceName(LF_FACESIZE) As Byte
  249. End Type
  250. Private Const FW_NORMAL = 400
  251. Private Const FW_BOLD = 700
  252. Private Const FF_DONTCARE = 0
  253. Private Const DEFAULT_QUALITY = 0
  254. Private Const DEFAULT_PITCH = 0
  255. Private Const DEFAULT_CHARSET = 1
  256. Private Declare Function CreateFontIndirect& Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT)
  257. Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
  258. Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
  259.  
  260. Private Declare Function DrawState Lib "user32" Alias "DrawStateA" _
  261.     (ByVal hdc As Long, _
  262.     ByVal hBrush As Long, _
  263.     ByVal lpDrawStateProc As Long, _
  264.     ByVal lParam As Long, _
  265.     ByVal wParam As Long, _
  266.     ByVal x As Long, _
  267.     ByVal y As Long, _
  268.     ByVal cX As Long, _
  269.     ByVal cY As Long, _
  270.     ByVal fuFlags As Long) As Long
  271.  
  272. '/* Image type */
  273. Private Const DST_COMPLEX = &H0&
  274. Private Const DST_TEXT = &H1&
  275. Private Const DST_PREFIXTEXT = &H2&
  276. Private Const DST_ICON = &H3&
  277. Private Const DST_BITMAP = &H4&
  278.  
  279. ' /* State type */
  280. Private Const DSS_NORMAL = &H0&
  281. Private Const DSS_UNION = &H10& ' Dither
  282. Private Const DSS_DISABLED = &H20&
  283. Private Const DSS_MONO = &H80& ' Draw in colour of brush specified in hBrush
  284. Private Const DSS_RIGHT = &H8000&
  285.  
  286. Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
  287. Private Const CLR_INVALID = -1
  288.  
  289. ' Image list functions:
  290. Private Declare Function ImageList_GetBkColor Lib "COMCTL32" (ByVal hImageList As Long) As Long
  291. Private Declare Function ImageList_ReplaceIcon Lib "COMCTL32" (ByVal hImageList As Long, ByVal i As Long, ByVal hIcon As Long) As Long
  292. 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
  293. 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
  294. Private Declare Function ImageList_AddMasked Lib "COMCTL32" (ByVal hImageList As Long, ByVal hbmImage As Long, ByVal crMask As Long) As Long
  295. 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
  296. Private Declare Function ImageList_Add Lib "COMCTL32" (ByVal hImageList As Long, ByVal hbmImage As Long, hBmMask As Long) As Long
  297. Private Declare Function ImageList_Remove Lib "COMCTL32" (ByVal hImageList As Long, ByVal ImgIndex As Long) As Long
  298. Private Type IMAGEINFO
  299.     hBitmapImage As Long
  300.     hBitmapMask As Long
  301.     cPlanes As Long
  302.     cBitsPerPixel As Long
  303.     rcImage As RECT
  304. End Type
  305. Private Declare Function ImageList_GetImageInfo Lib "COMCTL32.DLL" ( _
  306.         ByVal hIml As Long, _
  307.         ByVal i As Long, _
  308.         pImageInfo As IMAGEINFO _
  309.     ) As Long
  310. Private Declare Function ImageList_AddIcon Lib "COMCTL32" (ByVal hIml As Long, ByVal hIcon As Long) As Long
  311. Private Declare Function ImageList_GetIcon Lib "COMCTL32" (ByVal hImageList As Long, ByVal ImgIndex As Long, ByVal fuFlags As Long) As Long
  312. Private Declare Function ImageList_SetImageCount Lib "COMCTL32" (ByVal hImageList As Long, uNewCount As Long)
  313. Private Declare Function ImageList_GetImageCount Lib "COMCTL32" (ByVal hImageList As Long) As Long
  314. Private Declare Function ImageList_Destroy Lib "COMCTL32" (ByVal hImageList As Long) As Long
  315. Private Declare Function ImageList_GetIconSize Lib "COMCTL32" (ByVal hImageList As Long, cX As Long, cY As Long) As Long
  316. Private Declare Function ImageList_SetIconSize Lib "COMCTL32" (ByVal hImageList As Long, cX As Long, cY As Long) As Long
  317.  
  318. ' ImageList functions:
  319. ' Draw:
  320. Private Declare Function ImageList_Draw Lib "COMCTL32.DLL" ( _
  321.         ByVal hIml As Long, _
  322.         ByVal i As Long, _
  323.         ByVal hdcDst As Long, _
  324.         ByVal x As Long, _
  325.         ByVal y As Long, _
  326.         ByVal fStyle As Long _
  327.     ) As Long
  328. Private Const ILD_NORMAL = 0&
  329. Private Const ILD_TRANSPARENT = 1&
  330. Private Const ILD_BLEND25 = 2&
  331. Private Const ILD_SELECTED = 4&
  332. Private Const ILD_FOCUS = 4&
  333. Private Const ILD_MASK = &H10&
  334. Private Const ILD_IMAGE = &H20&
  335. Private Const ILD_ROP = &H40&
  336. Private Const ILD_OVERLAYMASK = 3840&
  337. Private Declare Function ImageList_GetImageRect Lib "COMCTL32.DLL" ( _
  338.         ByVal hIml As Long, _
  339.         ByVal i As Long, _
  340.         prcImage As RECT _
  341.     ) As Long
  342. ' Messages:
  343. 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
  344. 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)
  345. Private Declare Function ImageList_SetBkColor Lib "COMCTL32" (ByVal hImageList As Long, ByVal clrBk As Long) As Long
  346.  
  347. Private Const ILC_MASK = &H1&
  348.  
  349. Private Const CLR_DEFAULT = -16777216
  350. Private Const CLR_HILIGHT = -16777216
  351. Private Const CLR_NONE = -1
  352.  
  353. Private Const ILCF_MOVE = &H0&
  354. Private Const ILCF_SWAP = &H1&
  355. 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
  356.  
  357. 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
  358. Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
  359. Private Const MAX_PATH = 260
  360. Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
  361.  
  362. Private Type PictDesc
  363.     cbSizeofStruct As Long
  364.     picType As Long
  365.     hImage As Long
  366.     xExt As Long
  367.     yExt As Long
  368. End Type
  369. Private Type Guid
  370.     Data1 As Long
  371.     Data2 As Integer
  372.     Data3 As Integer
  373.     Data4(0 To 7) As Byte
  374. End Type
  375. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
  376.  
  377. ' -----------
  378. ' ENUMS
  379. ' -----------
  380. Public Enum eilIconState
  381.   Normal = 0
  382.   Disabled = 1
  383. End Enum
  384.  
  385. Public Enum ImageTypes
  386.   IMAGE_BITMAP = 0
  387.   IMAGE_ICON = 1
  388.   IMAGE_CURSOR = 2
  389. End Enum
  390.  
  391. Public Enum eilColourDepth
  392.     ILC_COLOR = &H0
  393.     ILC_COLOR4 = &H4
  394.     ILC_COLOR8 = &H8
  395.     ILC_COLOR16 = &H10
  396.     ILC_COLOR24 = &H18
  397.     ILC_COLOR32 = &H20
  398. End Enum
  399.  
  400. Public Enum eilSwapTypes
  401.    eilCopy = ILCF_MOVE
  402.    eilSwap = ILCF_SWAP
  403. End Enum
  404.  
  405. ' ------------------
  406. ' Private variables:
  407. ' ------------------
  408. Private m_hIml As Long
  409. Private m_lIconSizeX As Long
  410. Private m_lIconSizeY As Long
  411. Private m_eColourDepth As eilColourDepth
  412. Private m_sKey() As String
  413. Private m_HDC As Long
  414.  
  415. Public Property Let OwnerHDC(ByVal lHDC As Long)
  416.    m_HDC = lHDC
  417. End Property
  418.  
  419. Public Property Get SystemColourDepth() As eilColourDepth
  420. Dim lR As Long
  421. Dim lHDC As Long
  422.    lHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
  423.    lR = GetDeviceCaps(lHDC, BITSPIXEL)
  424.    DeleteDC lHDC
  425.    SystemColourDepth = lR
  426. End Property
  427.  
  428. Public Sub SwapOrCopyImage( _
  429.       ByVal vKeySrc As Variant, _
  430.       ByVal vKeyDst As Variant, _
  431.       Optional ByVal eSwap As eilSwapTypes = eilSwap _
  432.    )
  433. Dim lDst As Long
  434. Dim lSrc As Long
  435. Dim sKeyDst As String
  436. Dim sKeySrc As String
  437.  
  438.    If (m_hIml <> 0) Then
  439.       lDst = ItemIndex(vKeySrc)
  440.       If (lDst > -1) Then
  441.          lSrc = ItemIndex(vKeyDst)
  442.          If (lSrc > -1) Then
  443.             ImageList_Copy m_hIml, lDst, m_hIml, lSrc, eSwap
  444.             sKeyDst = m_sKey(lDst)
  445.             sKeySrc = m_sKey(lSrc)
  446.             m_sKey(lDst) = sKeySrc
  447.             m_sKey(lSrc) = sKeyDst
  448.          End If
  449.       End If
  450.    End If
  451. End Sub
  452.  
  453. Public Function Create() As Boolean
  454.      
  455.      ' Do we already have an image list?  Kill it if we have:
  456.     Destroy
  457.  
  458.     'Create the Imagelist:
  459.     m_hIml = ImageList_Create(m_lIconSizeX, m_lIconSizeY, ILC_MASK Or m_eColourDepth, 4, 4)
  460.     If (m_hIml <> 0) And (m_hIml <> -1) Then
  461.       ' Ok
  462.       Create = True
  463.     Else
  464.       m_hIml = 0
  465.     End If
  466.     
  467. End Function
  468. Public Sub Destroy()
  469.    ' Kill the image list if we have one:
  470.    If (hIml <> 0) Then
  471.       ImageList_Destroy hIml
  472.       m_hIml = 0
  473.    End If
  474.    Erase m_sKey
  475. End Sub
  476. Public Sub DrawImage( _
  477.         ByVal vKey As Variant, _
  478.         ByVal hdc As Long, _
  479.         ByVal xPixels As Integer, _
  480.         ByVal yPixels As Integer, _
  481.         Optional ByVal bSelected = False, _
  482.         Optional ByVal bCut = False, _
  483.         Optional ByVal bDisabled = False, _
  484.         Optional ByVal oCutDitherColour As OLE_COLOR = CLR_NONE, _
  485.         Optional ByVal hExternalIml As Long = 0 _
  486.     )
  487. Dim hIcon As Long
  488. Dim hBr As Long
  489. Dim lFlags As Long
  490. Dim lhIml As Long
  491. Dim lColor As Long
  492. Dim iImgIndex As Long
  493.  
  494.    ' Draw the image at 1 based index or key supplied in vKey.
  495.    ' on the hDC at xPixels,yPixels with the supplied options.
  496.    ' You can even draw an ImageList from another ImageList control
  497.    ' if you supply the handle to hExternalIml with this function.
  498.    
  499.    iImgIndex = ItemIndex(vKey)
  500.    If (iImgIndex > -1) Then
  501.       If (hExternalIml <> 0) Then
  502.           lhIml = hExternalIml
  503.       Else
  504.           lhIml = hIml
  505.       End If
  506.       
  507.       lFlags = ILD_TRANSPARENT
  508.       If (bSelected) Or (bCut) Then
  509.           lFlags = lFlags Or ILD_SELECTED
  510.       End If
  511.       
  512.       If (bCut) Then
  513.         ' Draw dithered:
  514.         If (oCutDitherColour <> CLR_NONE) Then
  515.          lColor = TranslateColor(oCutDitherColour)
  516.       End If
  517.         If (lColor = -1) Then lColor = GetSysColor(COLOR_WINDOW)
  518.         ImageList_DrawEx _
  519.               lhIml, _
  520.               iImgIndex, _
  521.               hdc, _
  522.               xPixels, yPixels, 0, 0, _
  523.               CLR_NONE, lColor, _
  524.               lFlags
  525.       ElseIf (bDisabled) Then
  526.          ' extract a copy of the icon:
  527.          hIcon = ImageList_GetIcon(hIml, iImgIndex, 0)
  528.          ' Draw it disabled at x,y:
  529.          DrawState hdc, 0, 0, hIcon, 0, xPixels, yPixels, m_lIconSizeX, m_lIconSizeY, DST_ICON Or DSS_DISABLED
  530.          ' Clear up the icon:
  531.          DestroyIcon hIcon
  532.               
  533.       Else
  534.         ' Standard draw:
  535.         ImageList_Draw _
  536.             lhIml, _
  537.             iImgIndex, _
  538.             hdc, _
  539.             xPixels, _
  540.             yPixels, _
  541.             lFlags
  542.       End If
  543.    End If
  544. End Sub
  545.  
  546. Public Property Get IconSizeX() As Long
  547.    ' Returns the icon width
  548.     IconSizeX = m_lIconSizeX
  549. End Property
  550. Public Property Let IconSizeX(ByVal lSizeX As Long)
  551.    ' Sets the icon width.  NB no change at runtime unless you
  552.    ' call Create and add all the images in again.
  553.     m_lIconSizeX = lSizeX
  554. End Property
  555. Public Property Get IconSizeY() As Long
  556.    ' Returns the icon height:
  557.     IconSizeY = m_lIconSizeY
  558. End Property
  559. Public Property Let IconSizeY(ByVal lSizeY As Long)
  560.    ' Sets the icon height.  NB no change at runtime unless you
  561.    ' call Create and add all the images in again.
  562.     m_lIconSizeY = lSizeY
  563. End Property
  564. Public Property Get ColourDepth() As eilColourDepth
  565.    ' Returns the ColourDepth:
  566.     ColourDepth = m_eColourDepth
  567. End Property
  568. Public Property Let ColourDepth(ByVal eDepth As eilColourDepth)
  569.    ' Sets the ColourDepth.  NB no change at runtime unless you
  570.    ' call Create and rebuild the image list.
  571.     m_eColourDepth = eDepth
  572. End Property
  573.  
  574. Public Property Get ImageCount() As Integer
  575.    ' Returns the number of images in the ImageList:
  576.    If (hIml <> 0) Then
  577.       ImageCount = ImageList_GetImageCount(hIml)
  578.    End If
  579. End Property
  580. Public Sub RemoveImage(ByVal vKey As Variant)
  581. Dim lIndex As Long
  582. Dim i As Long
  583.    ' Removes an image from the ImageList:
  584.    If (hIml <> 0) Then
  585.       lIndex = ItemIndex(vKey)
  586.       ImageList_Remove hIml, lIndex
  587.       ' Fix up the keys:
  588.       For i = lIndex To ImageCount - 1
  589.          m_sKey(i) = m_sKey(i + 1)
  590.       Next i
  591.       pEnsureKeys
  592.    End If
  593.  
  594. End Sub
  595. Public Property Get KeyExists(ByVal sKey As String) As Boolean
  596. Dim iL As Long
  597. Dim iU As Long
  598.    If ImageCount > 0 Then
  599.       On Error Resume Next
  600.       iU = UBound(m_sKey)
  601.       If Err.Number <> 0 Then
  602.          iU = 0
  603.       End If
  604.       If (iU <> ImageCount - 1) Then
  605.          pEnsureKeys
  606.       End If
  607.       For iL = 0 To ImageCount - 1
  608.          If m_sKey(iL) = sKey Then
  609.             KeyExists = True
  610.             Exit For
  611.          End If
  612.       Next iL
  613.    End If
  614. End Property
  615.  
  616. Public Property Get ItemIndex(ByVal vKey As Variant) As Long
  617. Dim lR As Long
  618. Dim i As Long
  619.    ' Returns the 0 based Index for the selected
  620.    ' Image list item:
  621.    If (IsNumeric(vKey)) Then
  622.       lR = vKey
  623.       If (lR > 0) And (lR <= ImageCount) Then
  624.          ItemIndex = lR - 1
  625.       Else
  626.          ' error
  627.          Err.Raise 9, App.EXEName & ".vbalImageList"
  628.          ItemIndex = -1
  629.       End If
  630.    Else
  631.       lR = -1
  632.       For i = 0 To ImageCount - 1
  633.          If (m_sKey(i) = vKey) Then
  634.             lR = i
  635.             Exit For
  636.          End If
  637.       Next i
  638.       If (lR > 0) And (lR <= ImageCount) Then
  639.          ItemIndex = lR
  640.       Else
  641.          Err.Raise 9, App.EXEName & ".vbalImageList"
  642.          ItemIndex = -1
  643.       End If
  644.    End If
  645. End Property
  646. Public Property Get ItemKey(ByVal iIndex As Long) As Variant
  647.    ' Returns the Key for an image:
  648.    If (iIndex > 0) And (iIndex <= ImageCount) Then
  649.       ItemKey = m_sKey(iIndex - 1)
  650.    Else
  651.       Err.Raise 9, App.EXEName & ".vbalImageList"
  652.    End If
  653. End Property
  654. Public Property Let ItemKey(ByVal iIndex As Long, ByVal vKey As Variant)
  655.    ' Sets the Key for the an image:
  656.    iIndex = iIndex - 1
  657.    If (iIndex > 0) And (iIndex < ImageCount) Then
  658.       SetKey iIndex, vKey
  659.    Else
  660.       Err.Raise 9, App.EXEName & ".vbalImageList"
  661.    End If
  662. End Property
  663. Public Property Get ItemPicture(ByVal vKey As Variant) As IPicture
  664. Dim lIndex As Long
  665. Dim hIcon As Long
  666.    ' Returns a StdPicture for an image in the ImageList:
  667.    lIndex = ItemIndex(vKey)
  668.    If (lIndex > -1) Then
  669.       hIcon = ImageList_GetIcon(m_hIml, lIndex, ILD_TRANSPARENT)
  670.       If (hIcon <> 0) Then
  671.          Set ItemPicture = IconToPicture(hIcon)
  672.          ' Don't destroy the icon - it is now owned by
  673.          ' the picture object
  674.       End If
  675.    End If
  676.    
  677. End Property
  678. Public Property Get ItemCopyOfIcon(ByVal vKey As Variant) As Long
  679. Dim lIndex As Long
  680.    ' Returns a hIcon for an image in the ImageList.  User must
  681.    ' call DestroyIcon on the returned handle.
  682.    lIndex = ItemIndex(vKey)
  683.    If (lIndex > -1) Then
  684.       ItemCopyOfIcon = ImageList_GetIcon(m_hIml, lIndex, ILD_TRANSPARENT)
  685.    End If
  686. End Property
  687. Public Sub Clear()
  688.    ' Recreates the image list.
  689.    Create
  690. End Sub
  691. Public Function AddFromFile( _
  692.         ByVal sFIleName As String, _
  693.         ByVal iType As ImageTypes, _
  694.         Optional ByVal vKey As Variant, _
  695.         Optional ByVal bMapSysColors As Boolean = False, _
  696.         Optional ByVal lBackColor As OLE_COLOR = -1, _
  697.         Optional ByVal vKeyAfter As Variant _
  698.     ) As Long
  699. Dim hImage As Long
  700. Dim un2 As Long
  701. Dim lR As Long
  702.     
  703.    ' Adds an image or series of images from a file:
  704.    If (hIml <> 0) Then
  705.       un2 = LR_LOADFROMFILE
  706.       ' Load the image from file:
  707.       If bMapSysColors Then
  708.           un2 = un2 Or LR_LOADMAP3DCOLORS
  709.       End If
  710.       hImage = LoadImage(App.hInstance, sFIleName, iType, 0, 0, un2)
  711.       AddFromFile = AddFromHandle(hImage, iType, vKey, lBackColor, vKeyAfter)
  712.       Select Case iType
  713.       Case IMAGE_ICON
  714.          DestroyIcon hImage
  715.       Case IMAGE_CURSOR
  716.          DestroyCursor hImage
  717.       Case IMAGE_BITMAP
  718.          DeleteObject hImage
  719.       End Select
  720.    Else
  721.       ' no image list...
  722.       AddFromFile = False
  723.    End If
  724.                   
  725. End Function
  726. Public Function AddFromResourceID( _
  727.       ByVal lID As Long, _
  728.       ByVal hInst As Long, _
  729.       ByVal iType As ImageTypes, _
  730.       Optional ByVal vKey As Variant, _
  731.       Optional ByVal bMapSysColors As Boolean = False, _
  732.       Optional ByVal lBackColor As OLE_COLOR = -1, _
  733.       Optional ByVal vKeyAfter As Variant _
  734.     ) As Long
  735. Dim hImage As Long
  736. Dim un2 As Long
  737. Dim lR As Long
  738. Dim iX As Long, iY As Long
  739.     
  740.    ' Adds an image or series of images from a resource id.  Note this will
  741.    ' only work when working on a resource in a compiled executable:
  742.    If (hIml <> 0) Then
  743.       ' Load the image from file:
  744.       If bMapSysColors Then
  745.           un2 = un2 Or LR_LOADMAP3DCOLORS
  746.       End If
  747.       ' Choose the icon closest to the image list size:
  748.       If iType <> IMAGE_BITMAP Then
  749.          iX = m_lIconSizeX
  750.          iY = m_lIconSizeY
  751.       End If
  752.       If hInst = 0 Then
  753.          ' Assume we're trying to pick a shared
  754.          ' resource
  755.          un2 = un2 Or LR_COPYRETURNORG
  756.       End If
  757.       hImage = LoadImageLong(hInst, lID, iType, iX, iY, un2)
  758.       AddFromResourceID = AddFromHandle(hImage, iType, vKey, lBackColor, vKeyAfter)
  759.       Select Case iType
  760.       Case IMAGE_ICON
  761.          DestroyIcon hImage
  762.       Case IMAGE_CURSOR
  763.          DestroyCursor hImage
  764.       Case IMAGE_BITMAP
  765.          DeleteObject hImage
  766.       End Select
  767.    Else
  768.       ' no image list...
  769.       AddFromResourceID = False
  770.    End If
  771.    
  772. End Function
  773.  
  774. Public Function AddFromHandle( _
  775.       ByVal hImage As Long, _
  776.       ByVal iType As ImageTypes, _
  777.       Optional ByVal vKey As Variant, _
  778.       Optional ByVal lBackColor As OLE_COLOR = -1, _
  779.       Optional ByVal vKeyAfter As Variant _
  780.    ) As Boolean
  781. Dim lR As Long
  782. Dim lDst As Long
  783. Dim bOk As Boolean
  784. Dim bInsert As Boolean
  785. Dim i As Long, j As Long
  786. Dim iOrigCount As Long
  787. Dim iCount As Long
  788. Dim sSwapKey As String
  789.  
  790.    ' Adds an image or series of images from a GDI image handle.
  791.    If (m_hIml <> 0) Then
  792.       If (hImage <> 0) Then
  793.          iOrigCount = ImageCount
  794.          
  795.          bOk = True
  796.          If Not IsMissing(vKeyAfter) Then
  797.             If (ImageCount > 0) Then
  798.                If vKeyAfter = 0 Then
  799.                   bInsert = False
  800.                   lDst = 0
  801.                Else
  802.                   bInsert = True
  803.                   bOk = False
  804.                   lDst = ItemIndex(vKeyAfter)
  805.                   If (lDst > -1) Then
  806.                      bOk = True
  807.                   End If
  808.                End If
  809.             End If
  810.          End If
  811.          
  812.          If (bOk) Then
  813.             If (iType = IMAGE_BITMAP) Then
  814.                ' And add it to the image list:
  815.                If (lBackColor = -1) Then
  816.                    ' Ideally Determine the top left pixel of the
  817.                    ' bitmap and use as back colour...
  818.                    Dim lHDCDisp As Long, lHDC As Long, hBmpOld As Long
  819.                    lHDCDisp = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
  820.                    If lHDCDisp <> 0 Then
  821.                      lHDC = CreateCompatibleDC(lHDCDisp)
  822.                      DeleteDC lHDCDisp
  823.                      If lHDC <> 0 Then
  824.                         hBmpOld = SelectObject(lHDC, hImage)
  825.                         If hBmpOld <> 0 Then
  826.                            ' Get the colour of the 0,0 pixel:
  827.                            lBackColor = GetPixel(lHDC, 0, 0)
  828.                            SelectObject lHDC, hBmpOld
  829.                         End If
  830.                         DeleteObject lHDC
  831.                      End If
  832.                   End If
  833.                End If
  834.                lR = ImageList_AddMasked(hIml, hImage, lBackColor)
  835.             ElseIf (iType = IMAGE_ICON) Or (iType = IMAGE_CURSOR) Then
  836.                ' Add the icon:
  837.                lR = ImageList_AddIcon(hIml, hImage)
  838.             End If
  839.          End If
  840.          
  841.          If (lR > -1) Then
  842.             If (bInsert) Then
  843.                If (lDst < ImageCount - 1) Then
  844.                   ' We are inserting and have to swap all
  845.                   ' the images.
  846.                   pEnsureKeys
  847.                   iCount = ImageCount
  848.                   For i = iOrigCount - 1 To lDst Step -1
  849.                      For j = i To i + iCount - iOrigCount - 1
  850.                         ImageList_Copy m_hIml, j + 1, m_hIml, j, eilSwap
  851.                         sSwapKey = m_sKey(j)
  852.                         m_sKey(j) = m_sKey(j + 1)
  853.                         m_sKey(j + 1) = sSwapKey
  854.                      Next j
  855.                   Next i
  856.                   
  857.                End If
  858.             End If
  859.          End If
  860.          
  861.       Else
  862.           lR = -1
  863.       End If
  864.    Else
  865.       lR = -1
  866.    End If
  867.    
  868.    If (lR <> -1) Then
  869.       If bInsert Then
  870.          SetKey lDst, vKey
  871.       Else
  872.          SetKey lR, vKey
  873.       End If
  874.       AddFromHandle = (lR <> -1)
  875.    End If
  876.    pEnsureKeys
  877.    
  878. End Function
  879. Public Function AddFromPictureBox( _
  880.         ByVal hdc As Long, _
  881.         pic As Object, _
  882.         Optional ByVal vKey As Variant, _
  883.         Optional ByVal LeftPixels As Long = 0, _
  884.         Optional ByVal TopPixels As Long = 0, _
  885.         Optional ByVal lBackColor As OLE_COLOR = -1 _
  886.     ) As Long
  887. Dim lHDC As Long
  888. Dim lhBmp As Long, lhBmpOld As Long
  889. Dim tBM As BITMAP
  890. Dim lAColor As Long
  891. Dim lW As Long, lH As Long
  892. Dim hBrush As Long
  893. Dim tR As RECT
  894. Dim lR As Long
  895. Dim lBPixel As Long
  896.    
  897.    ' Adds an image or series of images from an area of a PictureBox
  898.    ' or other Device Context:
  899.    lR = -1
  900.    If (hIml <> 0) Then
  901.       ' Create a DC to hold the bitmap to transfer into the image list:
  902.       lHDC = CreateCompatibleDC(hdc)
  903.       If (lHDC <> 0) Then
  904.           lhBmp = CreateCompatibleBitmap(hdc, m_lIconSizeX, m_lIconSizeY)
  905.           If (lhBmp <> 0) Then
  906.               ' Get the backcolor to use:
  907.               If (lBackColor = -1) Then
  908.                   ' None specified, use the colour at 0,0:
  909.                   lBackColor = GetPixel(pic.hdc, 0, 0)
  910.               Else
  911.                   ' Try to get the specified backcolor:
  912.                   If OleTranslateColor(lBackColor, 0, lAColor) Then
  913.                       ' Failed- use default of silver
  914.                       lBackColor = &HC0C0C0
  915.                   Else
  916.                       ' Set to GDI version of OLE Color
  917.                       lBackColor = lAColor
  918.                   End If
  919.               End If
  920.               ' Select the bitmap into the DC
  921.               lhBmpOld = SelectObject(lHDC, lhBmp)
  922.               ' Clear the background:
  923.               hBrush = CreateSolidBrush(lBackColor)
  924.               tR.Right = m_lIconSizeX: tR.Bottom = m_lIconSizeY
  925.               FillRect lHDC, tR, hBrush
  926.               DeleteObject hBrush
  927.               
  928.               ' Get the source picture's dimension:
  929.               GetObjectAPI pic.Picture.Handle, LenB(tBM), tBM
  930.               lW = 16
  931.               lH = 16
  932.               If (lW + LeftPixels > tBM.bmWidth) Then
  933.                   lW = tBM.bmWidth - LeftPixels
  934.               End If
  935.               If (lH + TopPixels > tBM.bmHeight) Then
  936.                   lH = tBM.bmHeight - TopPixels
  937.               End If
  938.               If (lW > 0) And (lH > 0) Then
  939.                   ' Blt from the picture into the bitmap:
  940.                   lR = BitBlt(lHDC, 0, 0, lW, lH, hdc, LeftPixels, TopPixels, SRCCOPY)
  941.                   Debug.Assert (lR <> 0)
  942.               End If
  943.               
  944.               ' We now have the image in the bitmap, so select it out of the DC:
  945.               SelectObject lHDC, lhBmpOld
  946.               ' And add it to the image list:
  947.               AddFromHandle lhBmp, IMAGE_BITMAP, vKey, lBackColor
  948.                   
  949.               DeleteObject lhBmp
  950.           End If
  951.           ' Clear up the DC:
  952.           DeleteDC lHDC
  953.       End If
  954.    End If
  955.  
  956.    If (lR <> -1) Then
  957.         SetKey lR, vKey
  958.    End If
  959.    
  960.    AddFromPictureBox = lR + 1
  961.    pEnsureKeys
  962.    
  963. End Function
  964. Private Sub SetKey(ByVal lIndex As Long, ByVal vKey As Variant)
  965. Dim sKey As String
  966. Dim lI As Long
  967.  
  968.    If (IsEmpty(vKey) Or IsMissing(vKey)) Then
  969.       sKey = ""
  970.    Else
  971.       sKey = vKey
  972.    End If
  973.     
  974.    If (m_hIml <> 0) Then
  975.       
  976.       On Error Resume Next
  977.       lI = UBound(m_sKey)
  978.       If (Err.Number = 0) Then
  979.          If (lIndex > lI) Then
  980.             ReDim Preserve m_sKey(0 To lIndex) As String
  981.          End If
  982.       Else
  983.          ReDim Preserve m_sKey(0 To lIndex) As String
  984.       End If
  985.       
  986.       For lI = 0 To UBound(m_sKey)
  987.          If Not lI = lIndex Then
  988.             If Trim$(m_sKey(lI)) <> "" Then
  989.                If m_sKey(lI) = vKey Then
  990.                   Err.Raise 457
  991.                   Exit Sub
  992.                End If
  993.             End If
  994.          End If
  995.       Next lI
  996.       m_sKey(lIndex) = vKey
  997.    End If
  998. End Sub
  999. Public Property Get hIml() As Long
  1000.    ' Returns the ImageList handle:
  1001.     hIml = m_hIml
  1002. End Property
  1003. Public Property Get ImagePictureStrip( _
  1004.       Optional ByVal vStartKey As Variant, _
  1005.       Optional ByVal vEndKey As Variant, _
  1006.       Optional ByVal oBackColor As OLE_COLOR = vbButtonFace _
  1007.    ) As IPicture
  1008. Dim iStart As Long
  1009. Dim iEnd As Long
  1010. Dim iImgIndex As Long
  1011. Dim lHDC As Long
  1012. Dim lParenthDC As Long
  1013. Dim lhBmp As Long
  1014. Dim lhBmpOld As Long
  1015. Dim lSizeX As Long
  1016. Dim hBr As Long
  1017. Dim tR As RECT
  1018. Dim lColor As Long
  1019.    
  1020.    If (m_hIml <> 0) Then
  1021.       If (IsMissing(vStartKey)) Then
  1022.          iStart = 0
  1023.       Else
  1024.          iStart = ItemIndex(vStartKey)
  1025.       End If
  1026.       If (IsMissing(vEndKey)) Then
  1027.          iEnd = ImageCount - 1
  1028.       Else
  1029.          iEnd = ItemIndex(vEndKey)
  1030.       End If
  1031.       
  1032.       If (iEnd > iStart) And (iEnd > -1) Then
  1033.          lParenthDC = m_HDC
  1034.          lHDC = CreateCompatibleDC(lParenthDC)
  1035.          If (lHDC <> 0) Then
  1036.             lSizeX = ImageCount * m_lIconSizeX
  1037.             lhBmp = CreateCompatibleBitmap(lParenthDC, lSizeX, m_lIconSizeY)
  1038.             If (lhBmp <> 0) Then
  1039.                lhBmpOld = SelectObject(lHDC, lhBmp)
  1040.                If (lhBmpOld <> 0) Then
  1041.                   lColor = TranslateColor(oBackColor)
  1042.                   tR.Bottom = m_lIconSizeY
  1043.                   tR.Right = lSizeX
  1044.                   hBr = CreateSolidBrush(lColor)
  1045.                   FillRect lHDC, tR, hBr
  1046.                   DeleteObject hBr
  1047.                   For iImgIndex = iStart To iEnd
  1048.                      ImageList_Draw m_hIml, iImgIndex, lHDC, iImgIndex * m_lIconSizeX, 0, ILD_TRANSPARENT
  1049.                   Next iImgIndex
  1050.                   SelectObject lHDC, lhBmpOld
  1051.                   Set ImagePictureStrip = BitmapToPicture(lhBmp)
  1052.                Else
  1053.                   DeleteObject lhBmp
  1054.                End If
  1055.             End If
  1056.             DeleteDC lHDC
  1057.          End If
  1058.       End If
  1059.    End If
  1060.    
  1061. End Property
  1062.  
  1063. Public Function IconToPicture(ByVal hIcon As Long) As IPicture
  1064.     
  1065.     If hIcon = 0 Then Exit Function
  1066.         
  1067.     ' This is all magic if you ask me:
  1068.     Dim NewPic As Picture, PicConv As PictDesc, IGuid As Guid
  1069.     
  1070.     PicConv.cbSizeofStruct = Len(PicConv)
  1071.     PicConv.picType = vbPicTypeIcon
  1072.     PicConv.hImage = hIcon
  1073.     
  1074.     ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  1075.     With IGuid
  1076.         .Data1 = &H7BF80980
  1077.         .Data2 = &HBF32
  1078.         .Data3 = &H101A
  1079.         .Data4(0) = &H8B
  1080.         .Data4(1) = &HBB
  1081.         .Data4(2) = &H0
  1082.         .Data4(3) = &HAA
  1083.         .Data4(4) = &H0
  1084.         .Data4(5) = &H30
  1085.         .Data4(6) = &HC
  1086.         .Data4(7) = &HAB
  1087.     End With
  1088.     OleCreatePictureIndirect PicConv       Else
  1089.         .Da.n    
  1090.               ' We now hav.Data2 = &HBF32
  1091.         .Data3 = &H101A
  1092.         4ong, By = SelectObject(lHHype<> 0)))))))))> -1)
  1093.    o32
  1094.         .Data .Data4(2) = &H0
  1095.             If (lhivate Const DEFAULT_GUI_FONT = 17 'win95 only
  1096. Pr
  1097.    
  1098. End Function
  1099. Public Function AddFromPictureBox( _
  1100.         ByVal hW    4(2) If (lhivate Const DEFAULs LongE,dFromPiECT
  1101. DimDeclare FunctionAs Long, pcc   lhBmpOld = SelectObjetemInde<> 0 ateRectRgn Lib "gdi32"Lib "COMCTL32" r        BbjetemInde<DCtObjetemInde<> 0 pcc   If
  1102.       Next lI
  1103. R  ImageList_Copy.4(6) = he imagetObje        SelectgE,dFromPiECT
  1104. DByVal yPi 
  1105.                I 'win95    
  1106. Public ageTypes
  1107.   IMAGE_BITMA.      iEn DEFAUIconS     ectObject(lHDC, lhBmp)
  1108.                If (lhBmpOld <> 0)    IfCVal hInst As Lont= True
  1109.           again.
  1110.    Ie        SelectgE,dFrom SelectgE,dFrom SelectgE,dFrom SelectgE,dFrom SelectgE,dFdey, lBackColor.
  1111.    Ie        SelectgE,dFrom Selec
  1112.       irue
  1113.    From Selec
  1114.       irue
  1115.    Frec
  1116.       irue
  1117.                If (lH + TopPixels > tBM.bmHej Sub Clear(FFromPi(    ' n3     SelectObjeor As OLE_COLOR = -1 _
  1118.   on.
  1119.    
  1120.    iImgIndex = ItemIndebeong
  1121. Dim lW As Long, lHSBIh
  1122. Dim lW
  1123. Dim Ih
  1124. ndex =n the DC:
  1125.     5jjjjjjjjjjjjjjjjjjjWst, lIDom Selec    sKey =  if n jjjjjr(vKey)) rom    ByVal hImage roc As   ByVal hW    4(2) If (lhivad  End W    4(2) nd IfX, lFlags Or ILD_SELECTED
  1126.       End If
  1127.   sbjetemInde<=atethe DC:
  1128.   
  1129.   sbjetemIndectDeAX, l                      SelectOndectDeAX, lio