vbAccelerator - Contents of code file: fSysTrayIconMenu.frm

VERSION 5.00
Begin VB.Form fSysTrayIconMenu 
   BorderStyle     =   0  'None
   ClientHeight    =   2070
   ClientLeft      =   6330
   ClientTop       =   5595
   ClientWidth     =   5205
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2070
   ScaleWidth      =   5205
   ShowInTaskbar   =   0   'False
   Visible         =   0   'False
End
Attribute VB_Name = "fSysTrayIconMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit


' frmSysTray.
' Steve McMahon
' based on code supplied from Ben Baird:

'Author:
'        Ben Baird <psyborg@cyberhighway.com>
'        Copyright (c) 1997, Ben Baird
'
'Purpose:
'        Demonstrates setting an icon in the taskbar's
'        system tray without the overhead of subclassing
'        to receive events.

Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long)
 As Long

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
Private Const WM_CANCELMODE = &H1F
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long,
 ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As
 Long, ByVal hwnd As Long, lprc As RECT) As Long
' Track popup menu constants:
Private Const TPM_CENTERALIGN = &H4&
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_LEFTBUTTON = &H0&
Private Const TPM_RIGHTALIGN = &H8&
Private Const TPM_RIGHTBUTTON = &H2&

Private Const TPM_NONOTIFY = &H80&           '/* Don't send any notification
 msgs */
Private Const TPM_RETURNCMD = &H100
Private Const TPM_HORIZONTAL = &H0          '/* Horz alignment matters more */
Private Const TPM_VERTICAL = &H40           '/* Vert alignment matters more */

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias
 "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Private Const NIF_ICON = &H2
Private Const NIF_MESSAGE = &H1
Private Const NIF_TIP = &H4
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const MAX_TOOLTIP As Integer = 64
Private Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * MAX_TOOLTIP
End Type
Private nfIconData As NOTIFYICONDATA

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

Public Event SysTrayMouseDown(ByVal eButton As MouseButtonConstants)
Public Event SysTrayMouseUp(ByVal eButton As MouseButtonConstants)
Public Event SysTrayMouseMove()
Public Event SysTrayDoubleClick(ByVal eButton As MouseButtonConstants)
Public Event MenuClick(ByVal lIndex As Long, ByVal sKey As String)

Private WithEvents m_cM As cPopupMenu
Attribute m_cM.VB_VarHelpID = -1
Private m_bAddedMenuItem As Boolean
Private m_hWndOwner As Long

Public Sub Initialise(ByVal hWndOwner As Long)
   m_hWndOwner = hWndOwner
   'Add the icon to the system tray...
   With nfIconData
       .hwnd = Me.hwnd
       .uID = Me.Icon
       .uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
       .uCallbackMessage = WM_MOUSEMOVE
       .hIcon = Me.Icon.Handle
       .szTip = App.FileDescription & Chr$(0)
       .cbSize = Len(nfIconData)
   End With
   Shell_NotifyIcon NIM_ADD, nfIconData
   Set m_cM = New cPopupMenu
   m_cM.hWndOwner = hWndOwner

End Sub

Public Property Get ToolTip() As String
Dim sTip As String
Dim iPos As Long
    sTip = nfIconData.szTip
    iPos = InStr(sTip, Chr$(0))
    If (iPos <> 0) Then
        sTip = Left$(sTip, iPos - 1)
    End If
    ToolTip = sTip
End Property
Public Property Let ToolTip(ByVal sTip As String)
    If (sTip & Chr$(0) <> nfIconData.szTip) Then
        nfIconData.szTip = sTip & Chr$(0)
        nfIconData.uFlags = NIF_TIP
        Shell_NotifyIcon NIM_MODIFY, nfIconData
    End If
End Property
Public Property Get IconHandle() As Long
    IconHandle = nfIconData.hIcon
End Property
Public Property Let IconHandle(ByVal hIcon As Long)
    If (hIcon <> nfIconData.hIcon) Then
        nfIconData.hIcon = hIcon
        nfIconData.uFlags = NIF_ICON
        Shell_NotifyIcon NIM_MODIFY, nfIconData
    End If
End Property
Public Property Let ImageList(ils As Variant)
   m_cM.ImageList = ils
End Property
Public Property Get PopupMenuObject() As cPopupMenu
   Set PopupMenuObject = m_cM
End Property
Public Function AddMenuItem( _
      ByVal sCaption As String, _
      Optional ByVal sKey As String = "", _
      Optional ByVal bDefault As Boolean = False, _
      Optional ByVal lItemData As Long = 0, _
      Optional ByVal lParentIndex As Long = 0, _
      Optional ByVal lIconIndex As Long = -1, _
      Optional ByVal bChecked As Boolean = False, _
      Optional ByVal bEnabled As Boolean = True _
   ) As Long
Dim lR As Long
   lR = m_cM.AddItem(sCaption, , lItemData, lParentIndex, lIconIndex, bChecked,
    bEnabled, sKey)
   If lR > 0 Then
      If bDefault Then
         m_cM.Default(lR) = True
      End If
      AddMenuItem = lR
   End If
    
End Function
Private Function ValidIndex(ByVal lIndex As Long) As Boolean
   ValidIndex = (lIndex >= 1 And lIndex <= m_cM.Count)
End Function
Private Function ValidIndexVar(ByVal vKey As Variant, ByRef lIndex As Long) As
 Boolean
Dim lI As Long
Dim lIdx As Long
   If IsNumeric(vKey) Then
      lIdx = vKey
   Else
      For lI = 1 To m_cM.Count
         If m_cM.ItemKey(lI) = vKey Then
            lIdx = lI
            Exit For
         End If
      Next lI
   End If
   If ValidIndex(lIdx) Then
      ValidIndexVar = True
      lIndex = lIdx
   End If
End Function
Public Sub EnableMenuItem(ByVal lIndex As Long, ByVal bState As Boolean)
   If (ValidIndex(lIndex)) Then
      m_cM.Enabled(lIndex) = bState
   Else
      Err.Raise 9
   End If
End Sub
Public Function RemoveMenuItem(ByVal iIndex As Long) As Long
   If (ValidIndex(iIndex)) Then
      m_cM.RemoveItem iIndex
   Else
      Err.Raise 9
   End If
End Function
Public Property Get Default(ByVal vKey As Variant) As Boolean
Dim lIndex As Long
   If (ValidIndexVar(vKey, lIndex)) Then
      Default = m_cM.Default(lIndex)
   Else
      Err.Raise 9
   End If
End Property
Public Property Let Default(ByVal vKey As Variant, ByVal bState As Boolean)
Dim lIndex As Long
   If (ValidIndexVar(vKey, lIndex)) Then
       m_cM.Default(lIndex) = bState
   Else
       Err.Raise 9
   End If
End Property
Public Property Get Checked(ByVal vKey As Variant) As Boolean
Dim lIndex As Long
   If (ValidIndexVar(vKey, lIndex)) Then
      Checked = m_cM.Checked(lIndex)
   Else
      Err.Raise 9
   End If
End Property
Public Property Let Checked(ByVal vKey As Variant, ByVal bState As Boolean)
Dim lIndex As Long
   If (ValidIndexVar(vKey, lIndex)) Then
       m_cM.Checked(lIndex) = bState
   Else
       Err.Raise 9
   End If
End Property
Public Function ShowMenu()
Dim lIndex As Long
Dim lR As Long
Dim sKey As String
Dim tP As POINTAPI
Dim tR As RECT

   SetForegroundWindow Me.hwnd
   GetCursorPos tP
   lR = m_cM.ShowPopupAbsolute(tP.x, tP.y)
   If lR > 0 Then
      sKey = m_cM.ItemKey(lR)
      RaiseEvent MenuClick(lR, sKey)
   End If
   
End Function


Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y
 As Single)
   Dim lX As Long

   lX = Me.ScaleX(x, Me.ScaleMode, vbPixels)
   Select Case lX
   Case WM_MOUSEMOVE
      RaiseEvent SysTrayMouseMove
   Case WM_LBUTTONDOWN
      RaiseEvent SysTrayMouseDown(vbLeftButton)
   Case WM_LBUTTONUP
      RaiseEvent SysTrayMouseUp(vbLeftButton)
   Case WM_LBUTTONDBLCLK
      RaiseEvent SysTrayDoubleClick(vbLeftButton)
   Case WM_RBUTTONDOWN
      RaiseEvent SysTrayMouseDown(vbRightButton)
   Case WM_RBUTTONUP
      RaiseEvent SysTrayMouseUp(vbRightButton)
   Case WM_RBUTTONDBLCLK
      RaiseEvent SysTrayDoubleClick(vbRightButton)
   End Select

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Shell_NotifyIcon NIM_DELETE, nfIconData
    Set m_cM = Nothing
End Sub