Attribute VB_Name = "modSysTray" Option Explicit '============================================================================================================= ' ' modSysTray Standard Module ' -------------------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Last Update : June 19, 2001 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : cSysTray.cls (System tray icon class module - by Kevin Wilson) ' ' Description : The cSysTray.cls class module was written to give you COMPLETE functionality when it comes ' to placing icons in the system tray (next to the clock in the lower right corner of your ' screen). Using this module, you can add one or many icon(s) with just one instance of ' this class module, track user interaction with the various system tray icons you've added ' to the taskbar, modify the icon or the ToolTipText associated with those icons dynamically ' at run-time, and remove the icons when needed. ' A neat feature of this class module is that you don't have to clean up any icons that are ' placed! All you do is add them. When you destroy the variable that represents this class ' module by setting it equal to NOTHING, this class module automatically locates any icons ' that have not been deleted and deletes them for you, thus avoiding stranded icons in the ' system tray, and memory leaks due to memory objects being left to hang. ' ' Example Use : (See cSysTray.cls) ' '============================================================================================================= ' ' LEGAL: ' ' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit ' given where credit is due. Also, it is not required, but it would be appreciated if you would mention ' somewhere in your compiled program that that your program makes use of code written and distributed by ' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles. ' ' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server ' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products, ' utilities, or applications that directly compete with products, utilities, and applications created by Kevin ' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first ' obtaining the written consent of the author Kevin Wilson. ' ' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without ' warning or notice. Copyright© by Kevin Wilson. All rights reserved. ' '============================================================================================================= ' Constants - SetWindowLong(nIndex) Private Const GWL_WNDPROC = -4 ' Constants - Windows Messages Public Const WM_MOUSEMOVE As Long = &H200 Public Const WM_LBUTTONDOWN As Long = &H201 Public Const WM_LBUTTONUP As Long = &H202 Public Const WM_LBUTTONDBLCLK As Long = &H203 Public Const WM_RBUTTONDOWN As Long = &H204 Public Const WM_RBUTTONUP As Long = &H205 Public Const WM_RBUTTONDBLCLK As Long = &H206 Public Const WM_MBUTTONDOWN As Long = &H207 Public Const WM_MBUTTONUP As Long = &H208 Public Const WM_MBUTTONDBLCLK As Long = &H209 ' Custom Windows Message(s) Private WM_CUSTOM As Long ' Module Level Variables Private hForm() As Long Private hFormPrev() As Long Private hFormST() As cSysTray Private hFormCount As Integer Private BypassCheck As Boolean ' Win32 API Declarations Private Declare Function CallWindowProc 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 DefWindowProc Lib "USER32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function RegisterWindowMessage Lib "USER32" Alias "RegisterWindowMessageA" (ByVal LPString As String) As Long Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Function SubClass_GetCustMsg() As Long ' Make sure that the custom Windows message has been created for communication If WM_CUSTOM = 0 Then ' "RegisterWindowMessage" creates and registers a system-wide unique message with a value between &HC000 and &HFFFF WM_CUSTOM = RegisterWindowMessage("cSysTray_Comm_Message" & Chr(0)) If WM_CUSTOM = 0 Then Exit Function End If ' Return it SubClass_GetCustMsg = WM_CUSTOM End Function ' Subclass the specified form and keep track of it's info Public Function SubClass_Add(ByVal FormHandle As Long, ByRef SysTrayClass As cSysTray) As Boolean On Error Resume Next Dim MyCounter As Integer ' Validate passed parameter(s) If FormHandle = 0 Then Exit Function ' If the specified form has already been subclassed, DO NOT subclass it again or there will be serious errors If SubClass_Exists(FormHandle) = True Then Exit Function ' If there are no existing subclasses, create the first one If hFormCount <= 0 Then hFormCount = 1 ReDim hForm(1 To 1) As Long ReDim hFormPrev(1 To 1) As Long ReDim hFormST(1 To 1) As cSysTray Set hFormST(1) = SysTrayClass hForm(1) = FormHandle hFormPrev(1) = SetWindowLong(FormHandle, GWL_WNDPROC, AddressOf SubClass_Proc) ' If there are already existing subclasses, then add this one to them Else hFormCount = hFormCount + 1 ReDim Preserve hForm(1 To hFormCount) As Long ReDim Preserve hFormPrev(1 To hFormCount) As Long ReDim Preserve hFormST(1 To hFormCount) As cSysTray Set hFormST(hFormCount) = SysTrayClass hForm(hFormCount) = FormHandle hFormPrev(hFormCount) = SetWindowLong(FormHandle, GWL_WNDPROC, AddressOf SubClass_Proc) ' This line actually starts the form subclassing End If SubClass_Add = True End Function Public Function SubClass_Exists(ByVal FormHandle As Long) As Boolean On Error Resume Next Dim MyCounter As Integer ' Validate passed parameter(s) If FormHandle = 0 Then Exit Function ' If there are no forms subclassed yet, then exit If hFormCount <= 0 Then Exit Function ' Loop through the subclassed forms and see if one matches For MyCounter = 1 To hFormCount If hForm(MyCounter) = FormHandle Then SubClass_Exists = True Exit Function End If Next End Function Public Function SubClass_Remove(ByVal FormHandle As Long) As Boolean On Error Resume Next Dim MyCounter As Integer ' Validate passed parameter(s) If FormHandle = 0 Then Exit Function ' If the specified form was never subclassed by this module, we won't know what the ' previous procedure's handle was, so we can't safely un-subclass it... so exit out instead If BypassCheck = False Then If SubClass_Exists(FormHandle) = False Then Exit Function End If ' Find the index of the form we're looking for to get the previous proc's handle and ' cSysTray reference so we can properly clean up For MyCounter = 1 To hFormCount If hForm(MyCounter) = FormHandle Then Set hFormST(MyCounter) = Nothing SetWindowLong hForm(MyCounter), GWL_WNDPROC, hFormPrev(MyCounter) ' This line actually unsubclasses the form hForm(MyCounter) = 0 hFormPrev(MyCounter) = 0 ' If there was only 1 form subclassed, reset all the values to their defaults If hFormCount = 1 Then hFormCount = 0 Erase hForm Erase hFormPrev Erase hFormST ' If there were more than one, replace the one that was just removed with the last one ' in the array, then delete the last array item... thus dynamimcally resizing it as needed Else hForm(MyCounter) = hForm(hFormCount) hFormPrev(MyCounter) = hFormPrev(hFormCount) Set hFormST(MyCounter) = hFormST(hFormCount) hFormCount = hFormCount - 1 ReDim Preserve hForm(hFormCount) As Long ReDim Preserve hFormPrev(hFormCount) As Long ReDim Preserve hFormST(hFormCount) As cSysTray End If SubClass_Remove = True Exit Function End If Next End Function Public Sub SubClass_CleanUp(ByVal FormHandle As Long) On Error Resume Next Dim MyCounter As Integer ' If there are no subclasses, exit out If hFormCount <= 0 Then Exit Sub ' Loop through all existing subclasses and release them BypassCheck = True For MyCounter = 1 To hFormCount If hForm(MyCounter) = FormHandle Then SubClass_Remove hForm(MyCounter) End If Next BypassCheck = False End Sub 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Private Function SubClass_Proc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long On Error Resume Next Dim MyCounter As Long ' If no forms have been subclassed, this function should not be called... but in case it is, ' pass the message along to the default Windows handler If hFormCount <= 0 Then GoTo DefaultProc ' Check if the handle being passed to this procedure is one that has been subclassed by this module For MyCounter = 1 To hFormCount If hForm(MyCounter) = hWnd Then ' If the message is our custom message, call the cSysTray method first... then pass the message on If uMsg = SubClass_GetCustMsg Then hFormST(MyCounter).SysTrayEvent uMsg, wParam, lParam ' Pass the message on to where it should go for Windows to properly handle it SubClass_Proc = CallWindowProc(hFormPrev(MyCounter), hWnd, uMsg, wParam, lParam) Exit Function End If Next DefaultProc: ' Call the default window procedure to provide default processing for any window messages recieved SubClass_Proc = DefWindowProc(hWnd, uMsg, wParam, lParam) End Function