VBA, MS Access MS Access в примерах

Замена иконки формы (API)

По материалам: http://www.mvps.org  

Не существует прямого способа заменить иконку, но можно это сделать, загружая ICO файл в память и назначая значок на форму (посылаем WM_SETICON сообщение окну).

В форме на событие "Загрузка" вешаем нечто подобное:  

Private Sub Form_Load()
Dim b As Boolean
Dim sIconFilePath As String
    sIconFilePath = "d:\Temp\Application002.ico"
    b = SetFormIcon(Me.hWnd, sIconFilePath)
    If b = False Then Debug.Print "Установить иконку: " & sIconFilePath & "  - установить не удалось :("
End Sub



Модуль:

Option Compare Database
Option Explicit
'--------------------------------------------------------------------
' Module    : modFormsChangeIcon
' Author    : Code courtesy of Klaus H. Probst
' Date      : ??.??.2001
' Purpose   : Замена иконки формы
'--------------------------------------------------------------------
'
'// Place all this in a module
Public 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
   
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
   (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, LParam As Any) As Long
   
   
Public Const WM_GETICON = &H7F
Public Const WM_SETICON = &H80
Public Const ICON_SMALL = 0
Public Const ICON_BIG = 1

'// LoadImage() image types
Public Const IMAGE_BITMAP = 0
Public Const IMAGE_ICON = 1
Public Const IMAGE_CURSOR = 2
Public Const IMAGE_ENHMETAFILE = 3

'// LoadImage() flags
Public Const LR_DEFAULTCOLOR = &H0
Public Const LR_MONOCHROME = &H1
Public Const LR_COLOR = &H2
Public Const LR_COPYRETURNORG = &H4
Public Const LR_COPYDELETEORG = &H8
Public Const LR_LOADFROMFILE = &H10
Public Const LR_LOADTRANSPARENT = &H20
Public Const LR_DEFAULTSIZE = &H40
Public Const LR_LOADMAP3DCOLORS = &H1000
Public Const LR_CREATEDIBHeader = &H2000
Public Const LR_COPYFROMRESOURCE = &H4000
Public Const LR_SHARED = &H8000

Public Function SetFormIcon(hWnd As Long, IconPath As String) As Boolean
Dim hIcon As Long
'--------------------------------------------------------------------
On Error GoTo SetFormIcon_Err
   hIcon = LoadImage(0&, IconPath, IMAGE_ICON, 16, 16, LR_LOADFROMFILE)

   '// wParam = 0; Setting small icon. wParam = 1; setting large icon
   If hIcon <> 0 Then
      Call SendMessage(hWnd, WM_SETICON, 0, ByVal hIcon)
      SetFormIcon = True
   End If


SetFormIcon_Bye:
    Exit Function

SetFormIcon_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure SetFormIcon", vbCritical, "Error!"
    Resume SetFormIcon_Bye
End Function



Назад ToTop
L.E. 29.11.2024
Рейтинг@Mail.ru