Private Const GWL_STYLE = (-16)
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MINIMIZE = &H20000000
'LoadImage flags
Private Const WM_GETICON = &H7F 'message is sent to a window to retrieve a handle
' to the large or small icon associated with a window
Private Const WM_SETICON = &H80 'message to associate a new large or small icon with a window
Private Const IMAGE_BITMAP = 0 'Loads a bitmap.
Private Const IMAGE_ICON = 1 'Loads an icon.
Private Const IMAGE_CURSOR = 2 'Loads a cursor.
Private Const LR_LOADFROMFILE = &H10 'Loads the image from the file specified by
' the lpszName parameter. If this flag is not
' specified, lpszName is the name of the resource.
Private Const ICON_SMALL = 0& 'Retrieve the small icon for the window.
Private Const ICON_BIG = 1& 'Retrieve the large icon for the window.
'loads an icon, cursor, or bitmap.
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
'Send a message to a window via its handle
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
'SHGetFileInfo flags
Private Const SHGFI_ICON = &H100 'get icon
Private Const SHGFI_DISPLAYNAME = &H200 'get display name
Private Const SHGFI_TYPENAME = &H400 'get type name
Private Const SHGFI_ATTRIBUTES = &H800 'get attributes
Private Const SHGFI_ICONLOCATION = &H1000 'get icon location
Private Const SHGFI_EXETYPE = &H2000 'return exe type
Private Const SHGFI_SYSICONINDEX = &H4000 'get system icon index
Private Const SHGFI_LINKOVERLAY = &H8000 'put a link overlay on icon
Private Const SHGFI_SELECTED = &H10000 'show icon in selected state
Private Const SHGFI_ATTR_SPECIFIED = &H20000 'get only specified attributes
Private Const SHGFI_LARGEICON = &H0 'get large icon
Private Const SHGFI_SMALLICON = &H1 'get small icon
Private Const SHGFI_OPENICON = &H2 'get open icon
Private Const SHGFI_SHELLICONSIZE = &H4 'get shell size icon
Private Const SHGFI_PIDL = &H8 'pszPath is a pidl
Private Const SHGFI_USEFILEATTRIBUTES = &H10 'use passed dwFileAttribute
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const MAX_PATH = 260
Private Type SHFILEINFO
hIcon As Long 'Handle to the icon that represents the file.
iIcon As Long 'Index of the icon image within the system image list.
dwAttributes As Long 'Array of values that indicates the attributes of the file object.
szDisplayName As String * MAX_PATH 'String that contains the name of the file as it appears in the Windows shell
szTypeName As String * 80 'String that describes the type of file.
End Type
'Retrieves information about an object in the file system,
'such as a file, a folder, a directory, or a drive root.
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
'Declared here so we can use DestroyIcon afterwards
Private psfi As SHFILEINFO
'ShowWindow flags
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MINIMIZE = 6
Private Const SW_RESTORE = 9
'sets the specified window's show state.
Private Declare Function apiShowWindow Lib "user32" _
Alias "ShowWindow" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) _
As Long
'Shell_NotifyIcon Flags
Private Const NIM_ADD As Long = &H0 'Add an icon to the status area.
Private Const NIM_MODIFY As Long = &H1 'Modify an icon in the status area.
Private Const NIM_DELETE As Long = &H2 'Delete an icon from the status area.
'NOTIFYICONDATA flags
Private Const NIF_TIP As Long = &H4 'The szTip member is valid.
Private Const NIF_MESSAGE As Long = &H1 'The uCallbackMessage member is valid.
Private Const NIF_ICON As Long = &H2 'The hIcon member is valid.
'Messages
Private Const WM_MOUSEMOVE = &H200 'posted to a window when the cursor moves.
Private Const WM_LBUTTONDBLCLK = &H203 'Left Double-click
Private Const WM_LBUTTONDOWN = &H201 'Left Button down
Private Const WM_LBUTTONUP = &H202 'Left Button up
Private Const WM_RBUTTONDBLCLK = &H206 'Right Double-click
Private Const WM_RBUTTONDOWN = &H204 'Right Button down
Private Const WM_RBUTTONUP = &H205 'Right Button up
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 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
Private Declare Function apiSetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal wNewWord As Long) _
As Long
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) _
As Long
Private nID As NOTIFYICONDATA
Private lpPrevWndProc As Long
Private mblnCustomIcon As Boolean
Private lngWindowState As Long
Private Const GWL_WNDPROC As Long = (-4)
Function fWndProcTray(ByVal hwnd As Long, ByVal uMessage As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Select Case lParam
Case WM_LBUTTONUP:
Case WM_LBUTTONDBLCLK:
sUnhookTrayIcon hwnd
ToggleTaskbarButton hwnd
Call apiShowWindow(hwnd, lngWindowState)
SetForegroundWindow hwnd
Forms.FPanel.Visible = True
Case WM_LBUTTONDOWN:
Case WM_RBUTTONDBLCLK:
Case WM_RBUTTONDOWN:
Case WM_RBUTTONUP:
End Select
fWndProcTray = apiCallWindowProc(ByVal lpPrevWndProc, ByVal hwnd, ByVal uMessage, ByVal wParam, ByVal lParam)
End Function
Sub sHookTrayIcon(hwnd As Long, Optional strTipText As String, Optional strIconPath As String)
Dim lngStyle As Long
If fInitTrayIcon(hwnd, strTipText, strIconPath) Then
lngStyle = GetWindowLong(hwnd, GWL_STYLE)
If lngStyle And WS_MAXIMIZE Then
lngWindowState = SW_SHOWMAXIMIZED
ElseIf lngStyle And WS_MINIMIZE Then
lngWindowState = SW_SHOWMINIMIZED
Else
lngWindowState = SW_SHOWNORMAL
End If
lngWindowState = SW_SHOWMINIMIZED
apiShowWindow hwnd, SW_MINIMIZE
apiShowWindow hwnd, SW_HIDE
ToggleTaskbarButton hwnd
lpPrevWndProc = apiSetWindowLong(hwnd, GWL_WNDPROC, AddressOf fWndProcTray)
End If
End Sub
Sub sUnhookTrayIcon(hwnd As Long)
Call apiSetWindowLong(hwnd, GWL_WNDPROC, lpPrevWndProc)
Call apiShellNotifyIcon(NIM_DELETE, nID)
If mblnCustomIcon Then
Call fRestoreIcon(hwnd)
End If
Call apiDestroyIcon(psfi.hIcon)
End Sub
Private Function fExtractIcon() As Long
On Error GoTo ErrHandler
Dim hIcon As Long
hIcon = apiSHGetFileInfo(CurrentProject.Path & "\armada.ico", FILE_ATTRIBUTE_NORMAL, psfi, _
LenB(psfi), SHGFI_USEFILEATTRIBUTES Or SHGFI_SMALLICON Or SHGFI_ICON)
If Not hIcon = 0 Then fExtractIcon = psfi.hIcon
ExitHere:
Exit Function
ErrHandler:
fExtractIcon = False
Resume ExitHere
End Function
Private Function fRestoreIcon(hwnd As Long)
Call apiSendMessageLong(hwnd, WM_SETICON, 0&, fExtractIcon())
'Forms.fpanel.Visible = True
End Function
Private Function fSetIcon(hwnd As Long, strIconPath As String) As Long
Dim hIcon As Long
hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE)
If hIcon Then
Call apiSendMessageLong(hwnd, WM_SETICON, 0&, hIcon&)
mblnCustomIcon = True
fSetIcon = hIcon
' Else
' Forms.fpanel.Visible = True
End If
End Function
Private Function fInitTrayIcon(hwnd As Long, strTipText As String, strIconPath As String) As Boolean
Dim hIcon As Long
If strTipText = vbNullString Then strTipText = "Personel Takip Sistemi v.10.Acc"
If (strIconPath = vbNullString) Or (Dir(strIconPath) = vbNullString) Then
hIcon = fExtractIcon()
Else
hIcon = fSetIcon(hwnd, strIconPath)
End If
If hIcon Then
With nID
.cbSize = LenB(nID)
.hwnd = 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
