• Revista PROGRAMAR: Já está disponível a edição #53 da revista programar. Faz já o download aqui!

fLaSh_PT

Sytem Tray Icon & Popup Ballon Module!

1 mensagem neste tópico

Fiz esta a class a dois anos a traz para o projecto PTDCH.

Está a funcionar muito bem.. o right click no icon funciona sem problemas.. (que é um dos problemas deste tipo de codigo)

O único inseguro que tem.. é relacionado com a class interna do win32 para o sytray.. quando o Explorer crash.. a aplicação não faz o restore do icon.. tentei dar a volta.. mas não tive êxito.. também é um pequeno problema que raramente pode acontecer..

Este código tem de ser colocado em um module:

'-----------------------------------------------------------------
'             PT DC Hub @ Direct Connect P2P Network
'-----------------------------------------------------------------
'       Developer: Carlos DF (fLaSh)
'          E-mail: Carlosferreiracarlos@hotmail.com
' Project started: 10 - September - 2007
'         License: GNU General Public License.
'-----------------------------------------------------------------
'       Thanks to developers and contributores of SDCH/DDCH
'         The Left Hand, ButterflySoul, HaArD and Selyb
'  TheNOP, RollTheDice, JDommi, GhOstFaCE, ArchaicLight and TUFF
'-----------------------------------------------------------------
Option Explicit

'This is required so that when a popup menu is called the menu
'dismisses correctly if no item is chosen
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public 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

'This is used to find registered window messages, for explorer crash detection
'as well as to find the begining of program definable user messages ie: WM_APP
Public Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

'This will be used to help generate a GUID for use with creating our
'WM_TRAYHOOK
Private Declare Function CoCreateGuid Lib "ole32.dll" (pGuid As GUID) As Long

Public Type NOTIFYICONDATA
    cbSize              As Long             'Size of NotifyIconData struct
    hwnd                As Long             'Window handle for the window handling the icon events
    uID                 As Long             'Icon ID (to allow multiple icons per application)
    uFlags              As Long             'NIF Flags
    uCallbackMessage    As Long             'The message received for the system tray icon
    hIcon               As Long             'The memory location of our icon if NIF_ICON is specifed
    szTip               As String * 128     'Tooltip if NIF_TIP is specified (64 characters max)
    dwState             As Long
    dwStateMask         As Long
    szInfo              As String * 256
    uTimeout            As Long
    szInfoTitle         As String * 64
    dwInfoFlags         As Long
End Type

Public Enum BalloonIcon
    ICON_NONE = 0
    ICON_INFO = 1
    ICON_WARNING = 2
    ICON_ERROR = 3
    Icon_PTDCH = 4
End Enum

'BEGIN GUID HELPER
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

'Public mWndProcNext As Long
'Private bIsHooked As Boolean

Private TrayIcon As NOTIFYICONDATA

'used to indentify different tray icons if used
'Public WM_APP As Long  'For user defined window messages
Public WM_TRAYHOOK As Long 'The tray icon window message

'BEGIN EXPLORER.EXE CRASH DETECTION CODE
Public mTaskbarCreated As Long

Private Const GWL_WNDPROC = (-4)
Private Const GWL_USERDATA = (-21)

'Window messages relating to balloon tips and the like branch from here
Private Const WM_USER As Long = &H400

'Here are some mouse "events" to play with
'we are only going to use two in our example,
'however you feel free to use whatever you'd like (:

'Left Button
Public Const WM_LBUTTONDOWN As Long = &H201
Public Const WM_LBUTTONUP As Long = &H202
Public Const WM_LBUTTONDBLCLK As Long = &H203
' Middle Button
Public Const WM_MBUTTONDOWN As Long = &H207
Public Const WM_MBUTTONUP As Long = &H208
Public Const WM_MBUTTONDBLCLK As Long = &H209
' Right Button
Public Const WM_RBUTTONDOWN As Long = &H204
Public Const WM_RBUTTONUP As Long = &H205
Public Const WM_RBUTTONDBLCLK As Long = &H206

' Shell_NotifyIconA() messages
Private Const NIM_ADD As Long = &H0     'Add icon to the System Tray
Private Const NIM_MODIFY As Long = &H1  'Modify System Tray icon
Private Const NIM_DELETE As Long = &H2  'Delete icon from System Tray

'NotifyIconData Flags
Private Const NIF_MESSAGE As Long = &H1 'uCallbackMessage in NOTIFYICONDATA is valid
Private Const NIF_ICON As Long = &H2 ' hIcon in NOTIFYICONDATA is valid
Private Const NIF_TIP As Long = &H4 'szTip in NOTIFYICONDATA is valid
Private Const NIF_INFO As Long = &H10 'for use with balloons

'Balloon tip icon constants
Private Const NIIF_NONE As Long = &H0
Private Const NIIF_WARNING As Long = &H2
Private Const NIIF_ERROR As Long = &H3
Private Const NIIF_INFO As Long = &H1
Private Const NIIF_PTDCH As Long = &H4

'Balloon tip sound constants
Private Const NIIF_NOSOUND As Long = &H10

'Balloon tip notification messages
Public Const NIN_BALLOONSHOW As Long = WM_USER + &H2 'when the balloon is drawn
Public Const NIN_BALLOONHIDE As Long = WM_USER + &H3 'when the balloon disappears—for example, when the icon is deleted. This message is not sent if the balloon is dismissed because of a timeout or a mouse click.
Public Const NIN_BALLOONTIMEOUT As Long = WM_USER + &H4 'when the balloon is dismissed because of a timeout
Public Const NIN_BALLOONUSERCLICK As Long = WM_USER + &H5 'when the balloon is dismissed because of a mouse click.

Public Function CreateTrayIcon(ByRef Owner As Form, _
                               ByVal luID As Long, _
                      Optional ByRef ToolTip As String = "", _
                      Optional ByRef tIcon As StdPicture) As Long
      With TrayIcon
        .cbSize = Len(TrayIcon) 'This size is always the len(NOTIFYICONDATA)
        .hwnd = Owner.hwnd  'Which form is this icon for
        .uID = luID
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE    'set valid data inputs
        
        'You see this is where most VB tray icon codes are bad, no offense
        'they use a hack that uses the message WM_MOUSEMOVE for notification
        'this way VB can handle the message using its built in
        'Form_MouseMove event. This is not the way to do it in my opinion
        'because you can't have multiple icons for one form, my method allows
        'for this, not to mention the inability to detect explorer.exe crashes
        'but using the hack method you don't need to use message hooking either...
        'What window message should be sent during an event
        .uCallbackMessage = WM_TRAYHOOK
        .szTip = Trim(ToolTip$) & vbNullChar   'set the tooltip
        If tIcon Is Nothing Then
            .hIcon = Owner.Icon
        Else
            .hIcon = tIcon
        End If

      End With
    'Create the tray icon with an API call
    CreateTrayIcon = Shell_NotifyIcon(NIM_ADD, TrayIcon)
End Function

Public Function ModifyTrayIcon(ByRef Owner As Form, _
                               ByVal luID As Long, _
                      Optional ByRef ToolTip As String = "", _
                      Optional ByRef tIcon As StdPicture) As Long
    With TrayIcon
        .cbSize = Len(TrayIcon)
        .hwnd = Owner.hwnd
        .uID = luID
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uCallbackMessage = WM_TRAYHOOK
        If Not tIcon Is Nothing Then
            .hIcon = tIcon
        End If
        If Not ToolTip = "" Then .szTip = Trim(ToolTip$) & vbNullChar
    End With
    'Update the tray icon with an API call
    ModifyTrayIcon = Shell_NotifyIcon(NIM_MODIFY, TrayIcon)
End Function

Public Function DeleteTrayIcon(ByVal luID As Long) As Long
    With TrayIcon
        .cbSize = Len(TrayIcon)
        .uID = luID
        .uFlags = NIM_DELETE
        .uCallbackMessage = WM_TRAYHOOK
    End With   
     'Remove the tray icon with an API call
   DeleteTrayIcon = Shell_NotifyIcon(NIM_DELETE, TrayIcon)
End Function

Public Function InsertHook(ByRef Owner As Form) As Long
    Dim lResult As Long
    
    'Remove preexisting hook
    'Call RemoveHook(Owner)
    
    InsertHook = SetWindowLong(Owner.hwnd, GWL_WNDPROC, AddressOf GlobalMessageCatcher)
    If InsertHook Then
        lResult = SetWindowLong(Owner.hwnd, GWL_USERDATA, ObjPtr(Owner))
        'bIsHooked = True
    End If

End Function

Public Sub RemoveHook(ByRef Owner As Form, _
                      ByVal lHookID As Long)
     'Remove the hook and revert control back to VB
    
    If lHookID Then    'Make sure we really are hooked
        SetWindowLong Owner.hwnd, GWL_WNDPROC, lHookID
        'bIsHooked = False
    End If
End Sub

Public Function GlobalMessageCatcher(ByVal shWnd As Long, _
                                     ByVal uMsg As Long, _
                                     ByVal wParam As Long, _
                                     ByVal lParam As Long) As Long
    If shWnd = frmHub.hwnd Then
        GlobalMessageCatcher = frmHub.WindowProcSysTray(shWnd, uMsg, wParam, lParam)
    End If
End Function

Public Function PopupBalloon(ByRef Owner As Form, _
                             ByVal luID As Long, _
                             ByRef Title As String, _
                             ByRef Message As String, _
                    Optional ByVal IconType As BalloonIcon = ICON_INFO, _
                    Optional ByVal Sound As Boolean = True, _
                    Optional ByRef tIcon As StdPicture) As Long

    'This line is optional, if you include it new balloon tips erase old ones
    'if you omit it a balloon tip queue so to speak is created, and as they timeout
    'new ones appear
    Call RemoveBalloon(Owner, luID)
    With TrayIcon
         .cbSize = Len(TrayIcon)
        .hwnd = Owner.hwnd
        .uID = luID
        .uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE Or NIM_MODIFY
        .uCallbackMessage = WM_TRAYHOOK
        If tIcon Is Nothing Then
            .hIcon = Owner.Icon
        Else
            .hIcon = tIcon
        End If
        .dwState = 0
        .dwStateMask = 0
        .szInfo = Message & Chr(0)
        .szInfoTitle = Title & Chr(0)
        Select Case IconType
              Case ICON_NONE
                .dwInfoFlags = NIIF_NONE
              Case ICON_INFO
                .dwInfoFlags = NIIF_INFO
              Case ICON_WARNING
                .dwInfoFlags = NIIF_WARNING
              Case ICON_ERROR
                .dwInfoFlags = NIIF_ERROR
              Case Icon_PTDCH
                .dwInfoFlags = NIIF_PTDCH
           End Select
        If Not Sound Then .dwInfoFlags = .dwInfoFlags Or NIIF_NOSOUND
    End With
    
    PopupBalloon = Shell_NotifyIcon(NIM_MODIFY, TrayIcon)

End Function

Public Function RemoveBalloon(ByRef Owner As Form, _
                              ByVal luID As Long) As Long
    With TrayIcon
        .cbSize = Len(TrayIcon)
        .hwnd = Owner.hwnd
        .uID = luID
        .uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE Or NIM_MODIFY
        .uCallbackMessage = WM_TRAYHOOK
        .hIcon = Owner.Icon
        .dwState = 0
        .dwStateMask = 0
        .szInfo = Chr(0)
        .szInfoTitle = Chr(0)
        .dwInfoFlags = NIIF_NONE
    End With
    RemoveBalloon = Shell_NotifyIcon(NIM_MODIFY, TrayIcon)
End Function

Public Function GetGUID() As String
   Dim udtGUID As GUID
   If (CoCreateGuid(udtGUID) = 0) Then
      GetGUID = _
        String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & _
        String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & _
        String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & _
        IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
        IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & _
        IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
        IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
        IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
        IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
        IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
        IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
  End If
End Function

Para criar.. coloquei este código no Form_Load

         

'This gets us a globaly unique ID so that we can be sure the message
          'we use for getting our programs messages is unique
          WM_TRAYHOOK = RegisterWindowMessage(GetGUID())
          'This retrieves the window message for when the taskbar is created
          'since usually the application is run after the taskbar is created
          'it is safe to assume that if your program receives this message
          'any icon in the tray that was there is now gone and needs to be
          'recreated with a call to Shell_NotifyIcon(NIM_ADD, x)
           mTaskbarCreated = RegisterWindowMessage("PTDCH")
          'Create the tray icon
          CreateTrayIcon frmHub, 111&, "PT DC Hub " & vbVersion
          'Start the message hook
          m_lngHookID = InsertHook(frmHub)

Para terminar coloquem este código antes de a aplicação terminar (ex: form_unload())

     

'Remove system tray icon
       DeleteTrayIcon 111&
        'Remove the message hook  <=!!!IMPORTANT!!!
       RemoveHook frmHub, m_lngHookID

Para controlar o Popup Ballon é também o right click do icon.. é necessário criar uma SubClass no Form principal em questão..

(é so copiar este codigo)

Friend Function WindowProcSysTray(ByVal shWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    'Friend Function for sys tray
    'This is our message handler
     If shWnd = Me.hwnd Then 'First we check to see if the message is for this window
        Select Case uMsg    'Then we look at the message
              Case mTaskbarCreated    'This message is for when the taskbar is created
                  'if the taskbar was created, chances are explorer.exe had crashed
                CreateTrayIcon Me, 111&, "PT Direct Connect Hub " & vbVersion, Me.Icon  'recreate the tray icon
        
               Case WM_TRAYHOOK 'Our user defined window message
                'if we get this we know that lParam carries the "event"
                'that occured on the tray icon
            
                Select Case lParam
                      Case WM_LBUTTONDBLCLK   'Left button dbl clicked
                           
                        If Me.WindowState = vbMinimized Then
                            SetForegroundWindow Me.hwnd
                            Me.WindowState = vbNormal
                            Me.Show
                        Else
                            If Not IsActiveWin Then
                                SetWindowToTop Me
                            End If
                        End If
                        
                      Case WM_RBUTTONUP   'Right button released
                    
                        SetForegroundWindow Me.hwnd
                        RemoveBalloon Me, 111&
                        PopupMenu Me.mnuPopUp(0)
                    
                    Case NIN_BALLOONUSERCLICK
                          'User clicked the balloon.
                          '
                    Case NIN_BALLOONTIMEOUT
                          'Balloon disapeared floated away, or was dismissed.
              End Select
    
        End Select

       'also pass them to VB
       WindowProcSysTray = CallWindowProc(m_lngHookID, shWnd, uMsg, wParam, lParam)
    End If

End Function

A qualquer momento quando quiser mostrar o popup ballon.. só é necessário correr a função PopupBalloon

Qualquer duvida replay :D

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

Crie uma conta ou ligue-se para comentar

Só membros podem comentar

Criar nova conta

Registe para ter uma conta na nossa comunidade. É fácil!


Registar nova conta

Entra

Já tem conta? Inicie sessão aqui.


Entrar Agora