VB6中使用32位图标(第二版)

第一版参见：http://blog.youkuaiyun.com/Modest/archive/2008/05/06/2399774.aspx

本版添加了hIcon属性和SetFormIcon方法，顾名思义SetFormIcon就是实现vb6窗体的32位Icon应用。实现起来非常简单，发一个消息足矣。hIcon属性会根据图标索引返回图标句柄，用这个句柄还可以实现32位Icon在托盘中的美化应用。
(声明：魏滔序原创，转贴请注明出处。)

全部代码如下：

' ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'   VB6中使用32位图标(第二版)
'   Programmed by 魏滔序
'   WebSite: http://www.chenoe.com
'   Blog: http://blog.youkuaiyun.com/Modest
' :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
 
Option   Explicit

Private  Type ICONDIRENTRY
    bWidth   As   Byte
    bHeight   As   Byte
    bColorCount   As   Byte
    bReserved   As   Byte
    wPlanes   As   Integer
    wBitCount   As   Integer
    dwBytesInRes   As   Long
    dwImageOffset   As   Long
End  Type

Private  Type ICONDIR
    idReserved  As   Integer
    idType  As   Integer
    idCount  As   Integer
    idEntries()  As  ICONDIRENTRY
End  Type

Private   Declare   Function  CreateIconFromResourceEx  Lib   " user32 "  (presbits  As   Byte ,  ByVal  dwResSize  As   Long ,  ByVal  fIcon  As   Long ,  ByVal  dwVer  As   Long ,  ByVal  cxDesired  As   Long ,  ByVal  cyDesired  As   Long ,  ByVal  uFlags  As   Long )  As   Long
Private   Declare   Function  DrawIconEx  Lib   " user32.dll "  ( 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   Long
Private   Declare   Function  DestroyIcon  Lib   " user32 "  ( ByVal  hIcon  As   Long )  As   Long
Private   Declare   Sub  CopyMemory  Lib   " kernel32.dll "   Alias   " RtlMoveMemory "  ( ByRef  Destination  As  Any,  ByRef  Source  As  Any,  ByVal  Length  As   Long )
Private   Declare   Function  SendMessageLong  Lib   " user32 "   Alias   " SendMessageA "  ( ByVal  hWnd  As   Long ,  ByVal  wMsg  As   Long ,  ByVal  wParam  As   Long ,  ByVal  lParam  As   Long )  As   Long

Private  m_Data()  As   Byte
Private  m_iCount  As   Integer
Private  m_iDir  As  ICONDIR

Public   Property   Get  Count()  As   Long
    Count  =  m_iCount
End Property

Public   Property   Get  Height( Optional   ByVal  Index  As   Long )  As   Long
    Height  =  m_iDir.idEntries(Index).bHeight
End Property

Public   Property   Get  Width( Optional   ByVal  Index  As   Long )  As   Long
    Width  =  m_iDir.idEntries(Index).bWidth
End Property

Public   Property   Get  Length( Optional   ByVal  Index  As   Long )  As   Long
    Length  =  m_iDir.idEntries(Index).dwBytesInRes
End Property

Public   Property   Get  Data( Optional   ByVal  Index  As   Long )  As   Byte ()
     Dim  o  As   Long , l  As   Long , d()  As   Byte
    o  =  m_iDir.idEntries(Index).dwImageOffset
    l  =  m_iDir.idEntries(Index).dwBytesInRes
     ReDim  d(l  -   1 )
    CopyMemory d( 0 ), m_Data(o), l
    Data  =  d
End Property

Public   Function  LoadFromData(Data()  As   Byte )  As   Boolean
     Dim  i  As   Long
    m_Data  =  Data
    CopyMemory m_iCount, m_Data( 4 ),  2                        ' 取得图标个数
     If  m_iCount  >   0   Then
         ReDim  m_iDir.idEntries( 0   To  m_iCount  -   1 )           ' 图标目录结构数据
         For  i  =   0   To  m_iCount  -   1
            CopyMemory m_iDir.idEntries(i), m_Data( 6   +   Len (m_iDir.idEntries(i))  *  i),  Len (m_iDir.idEntries(i))
         Next
        LoadFromData  =   True
     End   If
End Function

Public   Function  LoadFromFile( ByVal  FileName  As   String )  As   Boolean
     Dim  hFile  As   Integer
     Dim  Data()  As   Byte

     If   Dir (FileName)  =   ""   Then   Exit Function
    
    hFile  =   FreeFile
    Open FileName  For  Binary  As  #hFile
     ReDim  Data( LOF (hFile)  -   1 )
     Get  #hFile, , Data
    Close #hFile

    LoadFromFile  =  LoadFromData(Data)
End Function

Public   Property   Get  hIcon( Optional   ByVal  Index  As   Long )  As   Long
     Dim  d()  As   Byte , l  As   Long , w  As   Long , h  As   Long
    d  =  Data(Index): l  =  Length(Index)
    w  =  Width(Index): h  =  Height(Index)
    hIcon  =  CreateIconFromResourceEx(d( 0 ), l,  1 ,  & H30000, w, h,  0 )
End Property

Public   Function  Draw( ByVal  hdc  As   Long ,  ByVal  x  As   Long ,  ByVal  y  As   Long ,  Optional   ByVal  Index  As   Long   =   0 )  As   Boolean
     Dim  w  As   Long , h  As   Long
    w  =  Width(Index): h  =  Height(Index)
    Draw  =  DrawIconEx(hdc, x, y, hIcon(Index), w, h,  0 ,  0 ,  3 )  <>   0
    DestroyIcon hIcon
End Function

Public   Sub  SetFormIcon( ByVal  Form  As  Form,  Optional   ByVal  Index  As   Long   =   0 )
    SendMessageLong Form.hWnd,  & H80,  0 , hIcon(Index)
End Sub

Private   Sub  Class_Terminate()
     Erase  m_Data
End Sub