Option Compare Database
Option Explicit
Private Const WM_GETICON = &H7F
Private Const WM_SETICON = &H80
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const LR_LOADFROMFILE = &H10
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&
Global Const SW_HIDE = 0
Global Const SW_SHOWNORMAL = 1
Global Const SW_SHOWMINIMIZED = 2
Global Const SW_SHOWMAXIMIZED = 5
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function apiLoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpszName As String, ByVal uType As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuLoad As Long) As Long
Private Declare Function apiSendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function apiSHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function apiDestroyIcon Lib "user32" Alias "DestroyIcon" (ByVal hIcon As Long) As Long
Private Declare Function apiShellNotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private Declare Function apiCallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function apiSetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long) As Long
'//SHGetFileInfo flags
Private Const SHGFI_ICON = &H100
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_TYPENAME = &H400
Private Const SHGFI_ATTRIBUTES = &H800
Private Const SHGFI_ICONLOCATION = &H1000
Private Const SHGFI_EXETYPE = &H2000
Private Const SHGFI_SYSICONINDEX = &H4000
Private Const SHGFI_LINKOVERLAY = &H8000
Private Const SHGFI_SELECTED = &H10000
Private Const SHGFI_ATTR_SPECIFIED = &H20000
Private Const SHGFI_LARGEICON = &H0
Private Const SHGFI_SMALLICON = &H1
Private Const SHGFI_OPENICON = &H2
Private Const SHGFI_SHELLICONSIZE = &H4
Private Const SHGFI_PIDL = &H8
Private Const SHGFI_USEFILEATTRIBUTES = &H10
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const MAX_PATH = 260
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Private psfi As SHFILEINFO
'//Shell_NotifyIcon Flags
Private Const NIM_ADD As Long = &H0
Private Const NIM_MODIFY As Long = &H1
Private Const NIM_DELETE As Long = &H2
'//NOTIFYICONDATA flags
Private Const NIF_TIP As Long = &H4
Private Const NIF_MESSAGE As Long = &H1
Private Const NIF_ICON As Long = &H2
'//Messages
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private nID As NOTIFYICONDATA
Global lpPrevWndProc As Long
Private mblnCustomIcon As Boolean
Public Const GWL_WNDPROC As Long = (-4)
Global DB_hWnd As Long
Public Function ApplicationOff()
Call sHookTrayIcon("fWndProcTray", "program adı", CurrentProject.Path & "\icon.ico")
End Function
Function fWndProcTray(ByVal hWnd As Long, _
ByVal uMessage As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
'receives messages indirectly from the operating system
'but allows us to perform additional functions
'for some of those messages.
'
On Error Resume Next
Select Case lParam
Case WM_LBUTTONUP: 'Left Button Up
Case WM_LBUTTONDBLCLK: 'Left Button Double click
Case WM_LBUTTONDOWN: 'Left Button down
Call apiShowWindow(hWnd, SW_SHOWMAXIMIZED)
Call sUnhookTrayIcon
DoCmd.Maximize
Case WM_RBUTTONDBLCLK: 'Right Double-click
Case WM_RBUTTONDOWN: 'Right Button down
Call apiShowWindow(hWnd, SW_SHOWMAXIMIZED)
Call sUnhookTrayIcon
Case WM_RBUTTONUP: 'Right Button Up
End Select
'return the messages back
fWndProcTray = apiCallWindowProc( _
ByVal lpPrevWndProc, _
ByVal hWnd, _
ByVal uMessage, _
ByVal wParam, _
ByVal lParam)
End Function
Sub sHookTrayIcon(strFunction As String, Optional strTipText As String, Optional strIconPath As String)
'Initialize the tray icon first
If fInitTrayIcon(strTipText, strIconPath) Then
Call apiShowWindow(DB_hWnd, SW_HIDE)
'Set new address for window's message handler
lpPrevWndProc = apiSetWindowLong(DB_hWnd, GWL_WNDPROC, AddressOf fWndProcTray)
End If
End Sub
Sub sUnhookTrayIcon()
'Restore the original message handler
Call apiSetWindowLong(DB_hWnd, GWL_WNDPROC, lpPrevWndProc)
'Call apiShowWindow(DB_hWnd, SW_SHOWMAXIMIZED)
'Remove the icon in the SysTray
Call apiShellNotifyIcon(NIM_DELETE, nID)
'Destroy the icon
Call apiDestroyIcon(psfi.hIcon)
End Sub
Public Function fExtractIcon() As Long
' Extracts the icon associated with an Access form
'
On Error GoTo ErrHandler
Dim hIcon As Long
'Don't need the full file name as Access form shortcuts
'have MAF extension. The SHGFI_USEFILEATTRIBUTES
'lets us pass an "invalid" file name to SHGetFileInfo
hIcon = apiSHGetFileInfo(".MAF", FILE_ATTRIBUTE_NORMAL, _
psfi, LenB(psfi), _
SHGFI_USEFILEATTRIBUTES Or _
SHGFI_SMALLICON Or SHGFI_ICON)
'Make sure there were no errors
If Not hIcon = 0 Then fExtractIcon = psfi.hIcon
ExitHere:
Exit Function
ErrHandler:
fExtractIcon = False
Resume ExitHere
End Function
Private Function fSetIcon(strIconPath As String) As Long
Dim hIcon As Long
'Load the 16x16 icon from file
hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE)
If hIcon Then
'First set the form's icon
'Call apiSendMessageLong(frm.hwnd, WM_SETICON, 0&, hIcon&)
Call apiSendMessageLong(DB_hWnd, WM_SETICON, 0&, hIcon&)
'This will tell us afterwards if we need to reset the form's icon
mblnCustomIcon = True
'Now return the hIcon
fSetIcon = hIcon
End If
End Function
Private Function fInitTrayIcon(strTipText As String, strIconPath As String) As Boolean
Dim hIcon As Long
'If the user didn't specify the tip text, use a default value
If strTipText = vbNullString Then strTipText = "MSAccess Form"
If (strIconPath = vbNullString) Or (Dir(strIconPath) = vbNullString) Then
'if there's no icon specified, use the form's default icon
hIcon = fExtractIcon()
Else
'load and set the icon
hIcon = fSetIcon(strIconPath)
End If
'If we were successful in previous step, then continue
'to place the icon in the system tray
If hIcon Then
With nID
.cbSize = LenB(nID)
.hWnd = DB_hWnd
.uID = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = hIcon
.szTip = strTipText & vbNullChar
End With
Call apiShellNotifyIcon(NIM_ADD, nID)
fInitTrayIcon = True
End If
End Function