Option Compare Database
Option Explicit
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 SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const WM_SETICON = &H80
Private Const IMAGE_ICON = 1
Private Const LR_LOADFROMFILE = &H10
Private Const SM_CXSMICON As Long = 49
Private Const SM_CYSMICON As Long = 50
'---------------------------------------------------------------------------------------
' Procedure : SetFormIcon
' DateTime : 03/02/2004 15:04
' Author : Ben O'Hara (bpo@robotparade.co.uk)
' Purpose : Adds custom icon to forms control box
'---------------------------------------------------------------------------------------
'
Public Function SetFormIcon(hWnd As Long, strIconPath As String) As Boolean
Dim lIcon As Long
Dim lResult As Long
Dim x As Long, Y As Long
10 On Error GoTo SetFormIcon_Error
20 x = GetSystemMetrics(SM_CXSMICON)
30 Y = GetSystemMetrics(SM_CYSMICON)
40 lIcon = LoadImage(0, strIconPath, 1, x, Y, LR_LOADFROMFILE)
50 lResult = SendMessage(hWnd, WM_SETICON, 0, ByVal lIcon)
SetFormIcon_Exit:
60 On Error Resume Next
70 Exit Function
SetFormIcon_Error:
80 Select Case Err.Number
Case Else
90 MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SetFormIcon of Module mdlSetIcon at Line " & Erl()
100 End Select
110 Resume SetFormIcon_Exit
End Function