systray.ctl

可以让您轻松设计WINDOWS托盘的控件源代码.

'-------------------------------------------------------
    Set TrayIcon = gTrayIcon                        ' Return Icon value
'-------------------------------------------------------
End Property
'-------------------------------------------------------

'-------------------------------------------------------
Public Property Let TrayTip(Tip As String)
Attribute TrayTip.VB_ProcData.VB_Invoke_PropertyPut = ";Misc"
Attribute TrayTip.VB_UserMemId = -517
'-------------------------------------------------------
    Dim Tray As NOTIFYICONDATA                      ' Notify Icon Data structure
    Dim rc As Long                                  ' API Return code
'-------------------------------------------------------
    If gAddedToTray Then                            ' if TrayIcon is in taskbar
        Tray.uID = gTrayId                          ' Unique ID for each HWND and callback message.
        Tray.hwnd = gTrayHwnd                       ' HWND receiving messages.
        Tray.szTip = Tip & vbNullChar               ' Tray tool tip
        Tray.uFlags = NIF_TIP                       ' Set flags for valid data items
        Tray.cbSize = Len(Tray)                     ' Size of struct.
        
        rc = Shell_NotifyIcon(NIM_MODIFY, Tray)     ' Send data to Sys Tray.
    End If
    
    gTrayTip = Tip                                  ' Save Tip
    PropertyChanged sTrayTip                        ' Notify control that property has changed
'-------------------------------------------------------
End Property
'-------------------------------------------------------

'-------------------------------------------------------
Public Property Get TrayTip() As String
'-------------------------------------------------------
    TrayTip = gTrayTip                              ' Return Global Tip...
'-------------------------------------------------------
End Property
'-------------------------------------------------------

'-------------------------------------------------------
Public Property Let InTray(Show As Boolean)
Attribute InTray.VB_ProcData.VB_Invoke_PropertyPut = ";Behavior"
'-------------------------------------------------------
    Dim ClassAddr As Long                           ' Address pointer to Control Instance
'-------------------------------------------------------
    If (Show <> gInTray) Then                       ' Modify ONLY if state is changing!
        If Show Then                                ' If adding Icon to system tray...
            If Ambient.UserMode Then                ' If in RunMode and not in IDE...
                 ' SubClass Controls window proc.
                PrevWndProc = SetWindowLong(gTrayHwnd, GWL_WNDPROC, AddressOf SubWndProc)
                
                ' Get address to user control object
                'CopyMemory ClassAddr, UserControl, 4&
                
                ' Save address to the USERDATA of the control's window struct.
                ' this will be used to get an object refenence to the control
                ' from an HWND in the callback.
                SetWindowLong gTrayHwnd, GWL_USERDATA, ObjPtr(Me) 'ClassAddr
                
                AddIcon gTrayHwnd, gTrayId, TrayTip, TrayIcon ' Add TrayIcon to System Tray...
                gAddedToTray = True                 ' Save state of control used in teardown procedure
            End If
        Else                                        ' If removing Icon from system tray
            If gAddedToTray Then                    ' If Added to system tray then remove...
                DeleteIcon gTrayHwnd, gTrayId       ' Remove icon from system tray
                
                ' Un SubClass controls window proc.
                SetWindowLong gTrayHwnd, GWL_WNDPROC, PrevWndProc
                gAddedToTray = False                ' Maintain the state for teardown purposes
            End If
        End If
        
        gInTray = Show                              ' Update global variable
        PropertyChanged sInTray                     ' Notify control that property has changed
    End If
'-------------------------------------------------------
End Property
'-------------------------------------------------------

'-------------------------------------------------------
Public Property Get InTray() As Boolean
'-------------------------------------------------------
    InTray = gInTray                                ' Return global property
'-------------------------------------------------------
End Property
'-------------------------------------------------------

'-------------------------------------------------------
Private Sub AddIcon(hwnd As Long, Id As Long, Tip As String, Optional Icon As StdPicture)
'-------------------------------------------------------
    Dim Tray As NOTIFYICONDATA                      ' Notify Icon Data structure
    Dim tFlags As Long                              ' Tray action flag
    Dim rc As Long                                  ' API return code
'-------------------------------------------------------
    Tray.uID = Id                                   ' Unique ID for each HWND and callback message.
    Tray.hwnd = hwnd                                ' HWND receiving messages.
    
    If Not (Icon Is Nothing) Then                   ' Validate Icon picture
        Tray.hIcon = Icon.Handle                    ' Tray icon.
        Tray.uFlags = Tray.uFlags Or NIF_ICON       ' Set ICON flag to validate data item
        Set gTrayIcon = Icon                        ' Save icon
    End If
    
    If (Tip <> "") Then                             ' Validate Tip text
        Tray.szTip = Tip & vbNullChar               ' Tray tool tip
        Tray.uFlags = Tray.uFlags Or NIF_TIP        ' Set TIP flag to validate data item
        gTrayTip = Tip                              ' Save tool tip
    End If
    
    Tray.uCallbackMessage = TRAY_CALLBACK           ' Set user defigned message
    Tray.uFlags = Tray.uFlags Or NIF_MESSAGE        ' Set flags for valid data item
    Tray.cbSize = Len(Tray)                         ' Size of struct.
    
    rc = Shell_NotifyIcon(NIM_ADD, Tray)            ' Send data to Sys Tray.
'-------------------------------------------------------
End Sub
'-------------------------------------------------------

'-------------------------------------------------------
Private Sub DeleteIcon(hwnd As Long, Id As Long)
'-------------------------------------------------------
    Dim Tray As NOTIFYICONDATA                      ' Notify Icon Data structure
    Dim rc As Long                                  ' API return code
'-------------------------------------------------------
    Tray.uID = Id                                   ' Unique ID for each HWND and callback message.
    Tray.hwnd = hwnd                                ' HWND receiving messages.
    Tray.uFlags = 0&                                ' Set flags for valid data items
    Tray.cbSize = Len(Tray)                         ' Size of struct.
    
    rc = Shell_NotifyIcon(NIM_DELETE, Tray)         ' Send delete message.
'-------------------------------------------------------
End Sub
'-------------------------------------------------------

'-------------------------------------------------------
Friend Sub SendEvent(MouseEvent As Long, Id As Long)
'-------------------------------------------------------
    Select Case MouseEvent                          ' Dispatch mouse events to control
    Case WM_MOUSEMOVE
        RaiseEvent MouseMove(Id)
    Case WM_LBUTTONDOWN
        RaiseEvent MouseDown(vbLeftButton, Id)
    Case WM_LBUTTONUP
        RaiseEvent MouseUp(vbLeftButton, Id)
    Case WM_LBUTTONDBLCLK
        RaiseEvent MouseDblClick(vbLeftButton, Id)
    Case WM_RBUTTONDOWN
        RaiseEvent MouseDown(vbRightButton, Id)
    Case WM_RBUTTONUP
        RaiseEvent MouseUp(vbRightButton, Id)
    Case WM_RBUTTONDBLCLK
        RaiseEvent MouseDblClick(vbRightButton, Id)
    End Select
'-------------------------------------------------------
End Sub
'-------------------------------------------------------