Источник: Rusimport
Игорь Макеев
Данный пример показывает как изменить стандартную иконку формы на свою иконку (ico) или бмпешку (bmp)
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Public Declare Function DestroyIcon Lib "user32" _
(ByVal hIcon As Long) As Long
Declare Function LoadImage Lib "user32" Alias "LoadImageA" _
(ByVal hInst As Long, ByVal lpsz As String, _
ByVal un1 As Long, ByVal n1 As Long, _
ByVal n2 As Long, ByVal un2 As Long) As Long
Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Public Const WM_SETICON = &H80
Public Const ICON_SMALL = 0
Public Const IMAGE_ICON = 1
Public Const LR_LOADFROMFILE = &H10
Private Sub Form_Open(Cancel As Integer)
SendMessage Me.hwnd, WM_SETICON, ICON_SMALL, _
LoadImage(0, "C:\TEST.ICO", IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
End Sub
Private Sub Form_Close()
Dim hIcon As Long
hIcon = SendMessage(hwnd, WM_SETICON, ICON_SMALL, 0)
If hIcon <> 0 Then DestroyIcon hIcon
End Sub
Ниже приведен пример модуля формы, который устанавливает в заголовок 16-тицветную бмпешку размером 16х16 точек. Прозрачным цветом в исходном bmp-файле считается белый.
Option Compare Database
Option Explicit
Private Const WM_SETICON = &H80
Private Const ICON_SMALL = 0
Private Const IMAGE_BITMAP = 0
Private Const LR_LOADFROMFILE = &H10
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" _
(ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateIconIndirect Lib "user32" _
(piconinfo As ICONINFO) As Long
Private Declare Function DestroyIcon Lib "user32" _
(ByVal hIcon As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" _
(ByVal hInst As Long, ByVal lpsz As String, _
ByVal un1 As Long, ByVal n1 As Long, _
ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function GetPixel Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal crColor As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Sub Form_Close()
Dim hIcon As Long
hIcon = SendMessage(hwnd, WM_SETICON, ICON_SMALL, 0)
If hIcon <> 0 Then DestroyIcon hIcon
End Sub
Private Sub Form_Open(Cancel As Integer)
Dim hIcon As Long, ii As ICONINFO
Dim hBmpMask As Long, hBmpColor As Long, ob As Long, ob1 As Long
Dim hDCMask As Long, hDCColor As Long
Dim x As Long, y As Long
hDCColor = CreateCompatibleDC(0)
hDCMask = CreateCompatibleDC(0)
' файл test.bmp - 16-тицветная картинка размером 16х16
hBmpColor = LoadImage(0, "c:\test.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
hBmpMask = CreateBitmap(16, 16, 1, 1, 0)
ob = SelectObject(hDCColor, hBmpColor)
ob1 = SelectObject(hDCMask, hBmpMask)
' делаем маску
For y = 0 To 15: For x = 0 To 15
If GetPixel(hDCColor, x, y) = &HFFFFFF Then
SetPixel hDCColor, x, y, 0: SetPixel hDCMask, x, y, &HFFFFFF
Else
SetPixel hDCMask, x, y, 0
End If
Next: Next
ii.hbmColor = SelectObject(hDCColor, ob)
ii.hbmMask = SelectObject(hDCMask, ob1)
ii.fIcon = 1
ii.xHotspot = 8: ii.yHotspot = 8
hIcon = CreateIconIndirect(ii)
SendMessage hwnd, WM_SETICON, ICON_SMALL, hIcon
DeleteObject hBmpColor
DeleteObject hBmpMask
DeleteDC hDCColor
DeleteDC hDCMask
End Sub
Ссылки по теме