看到带Alpha通道的32位图标那绚丽性感的外表，对于无法逃离“爱美之心人皆有之”这句俗话的人(包括我)早就垂涎三尺了。感谢微软给我们选择美丽的机会，能让我们自己的软件也在外表上成为让别人倾慕甚至以身相许的筹码。想起来容易，做起来才发现整容工作原来还真没那么简单。对于饱读“有志者事竟成,破釜沉舟百二秦关终属楚......”的我......嗯嗯嗯，夸张的天昏地暗、飞沙走石...... 终于皇天不负苦心人(又来了，其实我官方身份是诗人。)一个Very very简单的类诞生了。说了一堆废话，还是贴上源码吧，免得被人唾骂。
(声明：魏滔序原创，转贴请注明出处。)
请到这里下载源码：http://download.csdn.net/source/451058
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
' VB6中使用32位图标
' Programmed by 魏滔序
' WebSite: http://www.chenoe.com
' Blog: http://blog.csdn.net/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 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
发表于 @ 2008年05月06日 11:27:00|评论(loading...)|编辑