Code:
'FORM1.FRM
Dim NewCursor As Long, OldCursor As Long
'add 2 control: Text1,picture1
Private Sub Command1_Click()
Dim bt() As Byte
'bt = OpenBinFile(App.Path & "\02.ico")
Dim SizeArr() As String
SizeArr = GetIcoSizeArr(bt)
MsgBox Join(SizeArr, vbCrLf)
NewCursor = LoadIcoByByte(bt, 256, 32)
'NewCursor = LoadIcoByByte(bt, 0)
Text1.MousePointer = vbCustom
OldCursor = SetClassLong(Text1.hwnd, GCL_HCURSOR, NewCursor)
Picture1.Width = 256 * Screen.TwipsPerPixelX + Picture1.Width - Picture1.ScaleWidth
Picture1.Height = 256 * Screen.TwipsPerPixelY + Picture1.Height - Picture1.ScaleHeight
DrawIconEx Picture1.Hdc, 0, 0, NewCursor, 256, 256, 0, 0, DI_NORMAL
Picture1.Refresh
End Sub
Private Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.AutoSize = True
Command1_Click
End SubCode:
'*.BAS
Option Explicit
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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
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
Public Const GCL_HCURSOR = -12
Public Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const DI_NORMAL = &H3 '用常规方式绘图 (DI_IMAGE 和 DI_MASK)
Public Declare Function DrawIconEx Lib "user32" (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
Public Function GetIcoSizeArr(mIcon() As Byte) As String()
'good
'从字节数组内存流中创建ICO图标
Dim SizeArr() As String
Dim IDETY As ICONDIRENTRY
Dim W As Long, H As Long
Dim i As Long, iLen As Long, pData As Long, id As Long
iLen = LenB(IDETY)
pData = VarPtr(mIcon(0))
ReDim SizeArr(mIcon(4) - 1)
For i = 1 To mIcon(4) '第5个字节就是子图标的数目
CopyMemory IDETY, ByVal pData + 6 + (i - 1) * iLen, iLen '读 图标目录 结构数据
W = IDETY.bWidth
H = IDETY.bHeight
If W = H Then
If W = 0 Then W = 256: H = 256
SizeArr(id) = W & "*" & H & "," & IIf(IDETY.wBitCount = 0, "32位透明", IDETY.wBitCount)
id = id + 1
Else
Exit For
End If
Next
If id > 0 Then
ReDim Preserve SizeArr(id - 1)
Else
ReDim SizeArr(-1 To -1)
End If
GetIcoSizeArr = SizeArr
End Function
Public Function LoadIcoByByte(mIcon() As Byte, Optional ByVal iSize As Long = 16&, Optional BitCount As Long) As Long
'version 2021-5-13
'good
'从字节数组内存流中创建ICO图标,条件：大小，位度
Dim IDETY As ICONDIRENTRY, FindSize As Long
Dim i As Long, iLen As Long, pData As Long
Dim FindBitCount As Boolean
If iSize = 0 Then iSize = 256
If iSize = 256 Then
FindSize = 0
Else
FindSize = iSize
End If
iLen = LenB(IDETY)
pData = VarPtr(mIcon(0))
For i = 1 To mIcon(4) '第5个字节就是子图标的数目
CopyMemory IDETY, ByVal pData + 6 + (i - 1) * iLen, iLen '读 图标目录 结构数据
If BitCount = 0 Then
FindBitCount = True
Else
FindBitCount = IDETY.wBitCount = BitCount
End If
If FindBitCount Then
If iSize = -1 Then
iSize = IDETY.bWidth
If iSize = 0 Then iSize = 256 'edit:2021-5-13
GoTo DoLoadIco
ElseIf IDETY.bWidth = FindSize Then '寻找符合尺寸的子图标
DoLoadIco:
LoadIcoByByte = CreateIconFromResourceEx(mIcon(IDETY.dwImageOffset) _
, IDETY.dwBytesInRes, -1, &H30000, iSize, iSize, 0)
Exit For
End If
End If
Next
End Function
Function OpenBinFile(filename As String, Optional ErrInfo As String) As Byte()
'[mycode_id:1903],edittime:2011/7/11 13:27:34
On Error Resume Next
Dim hFile As Integer
hFile = FreeFile
Open filename For Binary As #hFile
ReDim OpenBinFile(LOF(hFile) - 1)
Get #hFile, , OpenBinFile
Close #hFile
End Function