VB6使用32位图标 代码收藏

看到带Alpha通道的32位图标那绚丽性感的外表，对于无法逃离“爱美之心人皆有之”这句俗话的人(包括我)早就垂涎三尺了。感谢微软给我们选择美丽的机会，能让我们自己的软件也在外表上成为让别人倾慕甚至以身相许的筹码。想起来容易，做起来才发现整容工作原来还真没那么简单。对于饱读“有志者事竟成,破釜沉舟百二秦关终属楚......”的我......嗯嗯嗯，夸张的天昏地暗、飞沙走石...... 终于皇天不负苦心人(又来了，其实我官方身份是诗人。)一个Very very简单的类诞生了。说了一堆废话，还是贴上源码吧，免得被人唾骂。
' ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'   VB6中使用32位图标
' :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
 

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  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   Function  Draw( ByVal  hdc  As   Long ,  ByVal  x  As   Long ,  ByVal  y  As   Long ,  Optional   ByVal  Index  As   Long   =   0 )  As   Boolean
     Dim  d()  As   Byte , l  As   Long , r  As   Long , w  As   Long , h  As   Long
    d  =  Data(Index): l  =  Length(Index)
    w  =  Width(Index): h  =  Height(Index)
    r  =  CreateIconFromResourceEx(d( 0 ), l,  1 ,  & H30000, w, h,  0 )
    Draw  =  DrawIconEx(hdc, x, y, r, w, h,  0 ,  0 ,  3 )  <>   0
    DestroyIcon r
End Function

Private   Sub  Class_Terminate()
     Erase  m_Data
End Sub

示例代码：

Private   Sub  Command1_Click()
     Dim  Icon  As   New  Icon
     Dim  IconIndex  As   Long
    
    IconIndex  =   3   ' 要显示的图标在图标组中的索引
    Icon.LoadFromFile App.Path  &   " a.ico "
    
     Me .Cls
    Icon.Draw  Me .hdc, ( Me .ScaleWidth  -  Icon.Width(IconIndex))  /   2 , ( Me .ScaleHeight  -  Icon.Height(IconIndex))  /   2 , IconIndex
     Me .Refresh
    
     Set  Icon  =   Nothing
End Sub