VB动态更改窗口图标的类(支持WinXP的32位图标)

Option Explicit

'======== clsIcon.cls ========

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 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 Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private iCount As Integer
Private iDir As ICONDIR
Private lpData() As Byte

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

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

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

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

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

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

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

If Dir(lpFileName) = "" Then Exit Function

hFile = FreeFile
Open lpFileName 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 lhWnd As Long, Optional ByVal Index As Long = 0)
SendMessageLong lhWnd, &H80, 0, hIcon(Index)
End Sub

Private Sub Class_Terminate()
Erase lpData
End Sub

'使用如下代码更改一个窗口的图标

If Dir(App.Path & "/Icon.ico") = "" Then Exit Sub 'Function
Dim ic As New clsIcon
ic.LoadFromFile App.Path & "/Icon.ico"
ic.SetFormIcon Me.hWnd 'hWnd Of a Window
Set ic = Nothing