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,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),3) <> 0 DestroyIcon hIcon End Function
Public Sub SetFormIcon(ByVal lhWnd As Long,Optional ByVal Index As Long = 0) SendMessageLong lhWnd,&H80,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 (编辑:李大同)
【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容!
|