VB6中使用32位图标

原帖：http://blog.csdn.net/Modest/archive/2008/05/06/2399774.aspx

'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' VB6中使用32位图标' Programmed by 魏滔序' WebSite: http://www.chenoe.com' Blog: http://blog.csdn.net/Modest'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: Option ExplicitPrivate 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 LongEnd TypePrivate Type ICONDIR idReserved As Integer idType As Integer idCount As Integer idEntries() As ICONDIRENTRYEnd TypePrivate 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 LongPrivate 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 LongPrivate Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As LongPrivate Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)Private m_Data() As BytePrivate m_iCount As IntegerPrivate m_iDir As ICONDIRPublic Property Get Count() As Long Count = m_iCountEnd PropertyPublic Property Get Height(Optional ByVal Index As Long) As Long Height = m_iDir.idEntries(Index).bHeightEnd PropertyPublic Property Get Width(Optional ByVal Index As Long) As Long Width = m_iDir.idEntries(Index).bWidthEnd PropertyPublic Property Get Length(Optional ByVal Index As Long) As Long Length = m_iDir.idEntries(Index).dwBytesInResEnd PropertyPublic 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 = dEnd PropertyPublic 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 IfEnd FunctionPublic 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 FunctionPublic 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 rEnd FunctionPrivate Sub Class_Terminate() Erase m_DataEnd 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 = NothingEnd Sub