mtray.bas

本程序可以设置本机自动与Internet时间同步。

Attribute VB_Name = "mTray"
Option Explicit

Public Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Const WM_USER = &H400
Public Const WM_NOTIFYICON = WM_USER + &H100

Public Type NOTIFYICONDATA
    cbSize As Long              ' 结构大小(字节)
    hwnd As Long                ' 处理消息的窗口的句柄
    uId As Long                 ' 唯一的标识符
    uFlags As Long              ' Flags
    uCallBackMessage As Long    ' 处理消息的窗口接收的消息
    hIcon As Long               ' 托盘图标句柄
    szTip As String * 128       ' Tooltip 提示文本
    dwState As Long             ' 托盘图标状态
    dwStateMask As Long         ' 状态掩码
    szInfo As String * 256      ' 气球提示文本
    uTimeoutOrVersion As Long   ' 气球提示消失时间或版本
    ' uTimeout - 气球提示消失时间(单位:ms, 10000 -- 30000)
    ' uVersion - 版本(0 for V4, 3 for V5)
    szInfoTitle As String * 64  ' 气球提示标题
    dwInfoFlags As Long         ' 气球提示图标
End Type

' dwState to NOTIFYICONDATA structure
Public Const NIS_HIDDEN = &H1              ' 隐藏图标
Public Const NIS_SHAREDICON = &H2          ' 共享图标

' dwInfoFlags to NOTIFIICONDATA structure
Public Const NIIF_NONE = &H0               ' 无图标
Public Const NIIF_INFO = &H1               ' "消息"图标
Public Const NIIF_WARNING = &H2            ' "警告"图标
Public Const NIIF_ERROR = &H3              ' "错误"图标
Public Const NIIF_GUID = &H4

' uFlags to NOTIFYICONDATA structure
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIF_STATE = &H8
Public Const NIF_INFO = &H10

' dwMessage to Shell_NotifyIcon
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIM_SETFOCUS = &H3
Public Const NIM_SETVERSION = &H4

' 关于气球提示的自定义消息, 2000下不产生这些消息
Public Const NIN_BALLOONSHOW = (WM_USER + &H2)      ' 当 Balloon Tips 弹出时执行
Public Const NIN_BALLOONHIDE = (WM_USER + &H3)      ' 当 Balloon Tips 消失时执行（如 SysTrayIcon 被删除），
' 但指定的 TimeOut 时间到或鼠标点击 Balloon Tips 后的消失不发送此消息
Public Const NIN_BALLOONTIMEOUT = (WM_USER + &H4)   ' 当 Balloon Tips 的 TimeOut 时间到时执行
Public Const NIN_BALLOONUSERCLICK = (WM_USER + &H5) ' 当鼠标点击 Balloon Tips 时执行。
' 注意:在XP下执行时 Balloon Tips 上有个关闭按钮,
' 如果鼠标点在按钮上将接收到 NIN_BALLOONTIMEOUT 消息。

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
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MBUTTONDBLCLK = &H209
Public Const WM_NCLBUTTONDBLCLK = &HA3

Public Const GWL_STYLE = -16
Public Const GWL_WNDPROC = -4

Public pWndProc As Long
Public Const sMyURL As String = "http://www.vbgood.com/viewthread.php?tid=76199"

' 拦截菜单消息 (窗口入口函数)
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim i As Integer, j As Integer
    Dim itemID As Long
    Dim t As String
    Dim pos As POINTAPI

    Select Case uMsg
      Case WM_COMMAND                                                 ' 单击菜单项
        If wParam < iMenuID And lParam = 0 Then MenuItemSelected wParam

      Case WM_EXITMENULOOP                                            ' 退出菜单消息循环(保留)

      Case WM_MEASUREITEM                                             ' 处理菜单项高度和宽度
        MeasureItem hwnd, lParam

      Case WM_MENUSELECT                                              ' 选择菜单项
        itemID = GetMenuItemID(lParam, wParam And &HFF)
        If itemID <> -1 Then MenuItemSelecting itemID

      Case WM_DRAWITEM                                                ' 绘制菜单项
        DrawItem lParam

      Case WM_NOTIFYICON                                              ' 点击托盘
        Select Case lParam

          Case WM_LBUTTONDBLCLK
            With frmMain.lstApp
                Call frmMain.CheckWin

                If .ListCount > 0 Then
                    frmMain.ShowWin .ListCount - 1
                Else
                    If MsgBox("您确定不再需要" & App.Title & "的帮助了吗？ :(", vbQuestion + vbYesNo + vbDefaultButton2, App.Title & " 提示") = vbYes Then
                        Unload frmMain
                    End If
                End If
            End With

          Case WM_RBUTTONDOWN
            For i = UBound(MyItemInfo) To 0 Step -1
                DeleteMenu hMenu, i, 0
            Next

            iMenuID = 0
            Erase MyItemInfo

            With frmMain.lstApp
                Call frmMain.CheckWin

                For i = 0 To .ListCount - 1
                    t = GetWinText(Val(.List(i)))

                    If frmMain.bTitleTrim Then
                        For j = 1 To Len(t)
                            If lstrlen(Left(t, j)) >= 20 Then
                                t = Left(t, j) & " ……"
                                Exit For
                            End If
                        Next
                    End If

                    AddItem CStr(i), GetIcon(GetProcessPath(Val(.List(i)))), t, MIT_STRING
                Next

                If .ListCount > 0 Then AddItem "sep", LoadPicture(), "", MIT_SEPARATOR

                If frmMain.tmrApp.Enabled Then
                    AddItem "hook", frmMain.lstWin.MouseIcon, "监控已开启", MIT_STRING
                Else
                    AddItem "hook", frmMain.lstAdd.MouseIcon, "监控已关闭", MIT_STRING
                End If

                AddItem "set", frmMain.lstApp.MouseIcon, "软件设置", MIT_STRING
                AddItem "sep", LoadPicture(), "", MIT_SEPARATOR
                AddItem "post", frmMain.lstOld.MouseIcon, "献良策", MIT_STRING
                AddItem "about", frmMain.MouseIcon, "关于本软件", MIT_STRING
                AddItem "exit", frmMain.lstNow.MouseIcon, "退出本软件", MIT_STRING
            End With

            GetCursorPos pos
            SetForegroundWindow frmMain.hwnd
            PopMenu pos.x, pos.y, POPUP_LEFTALIGN Or POPUP_TOPALIGN

        End Select
    End Select

    WindowProc = CallWindowProc(pWndProc, hwnd, uMsg, wParam, lParam)
End Function

Public Sub DoAction(ByVal iID As Long)
    With frmMain
        Select Case MyItemInfo(iID).itemAlias

          Case "about":
            ShellAbout .hwnd, App.Title & " V" & App.Major & "." & App.Minor & " Build " & Format$(App.Revision, "0000"), _
                       App.CompanyName & " 谢谢您的使用，欢迎前往论坛献良策", .Icon

          Case "exit":
            Unload frmMain

          Case "hook":
            .tmrApp.Enabled = Not .tmrApp.Enabled

          Case "post":
            ShellExecute 0, vbNullString, sMyURL, vbNullString, vbNullString, vbNormalFocus

          Case "set":
            .Show

          Case Else
            .ShowWin Val(MyItemInfo(iID).itemAlias)

        End Select
    End With
End Sub

Public Function GetWinText(ByVal lHwnd As Long) As String
    Dim s As String * 255

    GetWindowText lHwnd, s, 255
    GetWinText = Blank(s)
End Function

Public Function Blank(ByVal szString As String) As String
    Dim l As Integer

    l = InStr(szString, vbNullChar)
    If l > 0 Then
        Blank = Left(szString, l - 1)
    Else
        Blank = szString
    End If
End Function