GFSystray/GFSystray.frm
VERSION 5.00
Begin VB.Form GFSystrayfrm
BorderStyle = 1 'Fest Einfach
Caption = "Form1"
ClientHeight = 3270
ClientLeft = 45
ClientTop = 420
ClientWidth = 4770
Icon = "GFSystray.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3270
ScaleWidth = 4770
StartUpPosition = 3 'Windows‑Standard
Begin VB.ListBox List1
Height = 2400
Left = 60
TabIndex = 2
Top = 60
Width = 4635
End
Begin VB.CommandButton Command2
Caption = "Remove"
Height = 375
Left = 3360
TabIndex = 1
Top = 2820
Width = 1335
End
Begin VB.CommandButton Command1
Caption = "Add"
Height = 375
Left = 2040
TabIndex = 0
Top = 2820
Width = 1335
End
End
Attribute VB_Name = "GFSystrayfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001, 2004 by Louis. Note that the code is stolen from Matt Hart who partially stole it from http://www.windx.com.
'Note that the GFSystray code uses the GFSubClass functions (related module must be available).
'
'NOTE: an application calls GFSystray_Add() and passed the main form as
'the first two parameters. GFSystray_Add() will display the main form
'icon in the system tray. The target application should use
'.Hide to remove itself from screen. If the user right‑clicks on the icon
'the application should open a pop up‑menu, if he/she double‑clicks
'on the icon the application main form should become visible again.
'
'Downloaded from www.louis‑coder.com.
'Just copy this form's code to your project and add GFSubClassmod.
'You don't need to know how GFSubClassmod works, just let this form's
'code use it.
'
'GFSystray
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function Shell_NotifyIconA Lib "SHELL32" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Integer
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
'GFSystray
Private Const NIM_ADD = 0
Private Const NIM_MODIFY = 1
Private Const NIM_DELETE = 2
Private Const NIF_MESSAGE = 1
Private Const NIF_ICON = 2
Private Const NIF_TIP = 4
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209
'GFSystray
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
'GFSystray
Dim GFSystrayMessage As Long
Public Sub GFSubClassWindowProc(ByVal SourceDescription As String, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef ReturnValue As Long, ByRef ReturnValueUsedFlag As Boolean)
'on error resume next
Select Case Msg
Case GFSystrayMessage 'GFSystray (message 'from' Systray icon)
Select Case lParam
Case WM_MOUSEMOVE
'do nothing
Case WM_LBUTTONDOWN
List1.AddItem "Left Mouse Down"
Case WM_LBUTTONUP
List1.AddItem "Left Mouse Up"
Case WM_LBUTTONDBLCLK
'do nothing
Case WM_RBUTTONDOWN
List1.AddItem "Right Mouse Down"
Case WM_RBUTTONUP
List1.AddItem "Right Mouse Up"
Case WM_RBUTTONDBLCLK
'do nothing
End Select 'end of GFSystray
End Select
End Sub
Private Function GFSystray_Add(ByRef EventTargetObject As Object, ByRef EventTargetForm As Object, ByVal ToolTipText As String) As Boolean
'on error resume next
Dim NOTIFYICONDATAVar As NOTIFYICONDATA
'preset
If (GFSystrayMessage = 0) Then
'NOTE: the function below will generate a guaranteed‑working message (!?).
GFSystrayMessage = RegisterWindowMessage("GFSystray")
End If
NOTIFYICONDATAVar.cbSize = Len(NOTIFYICONDATAVar)
NOTIFYICONDATAVar.hIcon = EventTargetObject.Icon.Handle
NOTIFYICONDATAVar.hwnd = EventTargetObject.hwnd
NOTIFYICONDATAVar.szTip = ToolTipText + Chr$(0)
NOTIFYICONDATAVar.uCallbackMessage = GFSystrayMessage
NOTIFYICONDATAVar.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
NOTIFYICONDATAVar.uID = vbNull 'stolen
'begin
If Not (Shell_NotifyIconA(NIM_ADD, NOTIFYICONDATAVar) = 0) Then
GFSystray_Add = True 'ok
Call GFSubClass(EventTargetObject, "GFSystray_TargetObject", EventTargetForm, True)
Else
GFSystray_Add = False 'error
End If
End Function
Private Function GFSystray_Remove(ByRef EventTargetObject As Object, ByRef EventTargetForm As Object) As Boolean
'on error resume next
Dim NOTIFYICONDATAVar As NOTIFYICONDATA
'preset
NOTIFYICONDATAVar.cbSize = Len(NOTIFYICONDATAVar)
NOTIFYICONDATAVar.hIcon = EventTargetObject.Icon.Handle
NOTIFYICONDATAVar.hwnd = EventTargetObject.hwnd
NOTIFYICONDATAVar.szTip = "" + Chr$(0)
NOTIFYICONDATAVar.uCallbackMessage = 0
NOTIFYICONDATAVar.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP
NOTIFYICONDATAVar.uID = vbNull 'stolen
'begin
If Not (Shell_NotifyIconA(NIM_DELETE, NOTIFYICONDATAVar) = 0) Then
GFSystray_Remove = True 'ok
Call GFSubClass(EventTargetObject, "GFSystray_TargetObject", EventTargetForm, False)
Else
GFSystray_Remove = False 'error
End If
End Function
Private Sub Command1_Click()
'on error resume next
Debug.Print GFSystray_Add(GFSystrayfrm, GFSystrayfrm, "This is GFSystray")
End Sub
Private Sub Command2_Click()
'on error resume next
Debug.Print GFSystray_Remove(GFSystrayfrm, GFSystrayfrm)
End Sub
Private Sub Form_Unload(Cancel As Integer)
'on error resume next
Debug.Print GFSystray_Remove(GFSystrayfrm, GFSystrayfrm) 'remove all added icons
Call GFSubClass_Terminate 'important, call when your project is quit (or blue screens on Win32)
End Sub
[END OF FILE]