Изменение иконки у формы Ms AccessИсточник: 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 |