apistuff.bas

adsl拨号工具 有很多功能 不错啊 大家试试

Attribute VB_Name = "APIStuff"
Option Explicit
Public OldWindowProc As Long
Public TheForm As Form
Public TheMenu As Menu

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
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Declare Function Shell_NotifyIcon Lib "Shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

Public Const WM_USER = &H400
Public Const WM_LBUTTONUP = &H202
Public Const WM_MBUTTONUP = &H208
Public Const WM_RBUTTONUP = &H205
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIF_MESSAGE = &H1
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2

Public Type NOTIFYICONDATA
    cbSize As Long
    mhWnd As Long  '    hwnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

Private TheData As NOTIFYICONDATA

Public Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = TRAY_CALLBACK Then
        '单击图标还原窗口
        If lParam = WM_LBUTTONUP Then
            ' 单击左键，显示窗口
            If TheForm.WindowState = vbMinimized Then _
                TheForm.WindowState = TheForm.LastState
            RemoveFromTray
            '此处为显示窗口的名称
            frmDialupManage.Show
            TheForm.SetFocus
            Exit Function
        End If
        If lParam = WM_RBUTTONUP Then
            ' 单击右键，显示菜单
            TheForm.PopupMenu TheMenu
            Exit Function
        End If
    End If
    
    ' 传递消息至原窗口进程
    NewWindowProc = CallWindowProc( _
        OldWindowProc, hwnd, Msg, _
        wParam, lParam)
End Function

'添加图标到系统托盘
Public Sub AddToTray(frm As Form, mnu As Menu)
    '任务条在设计时需设为False,因为运行时是只读的

    '使用之后保存窗口和菜单
    Set TheForm = frm
    Set TheMenu = mnu
    
    '安装新的窗口进程
    OldWindowProc = SetWindowLong(frm.hwnd, _
        GWL_WNDPROC, AddressOf NewWindowProc)
    
    ' 在人物条上显示窗口的默认图标
    With TheData
        .uID = 0
        .hwnd = frm.hwnd
        .cbSize = Len(TheData)
        .hIcon = frm.Icon.Handle
        .uFlags = NIF_ICON
        .uCallbackMessage = TRAY_CALLBACK
        .uFlags = .uFlags Or NIF_MESSAGE
        .cbSize = Len(TheData)
    End With
    Shell_NotifyIcon NIM_ADD, TheData
End Sub

' 移除托盘图标
Public Sub RemoveFromTray()
    On Error Resume Next
    With TheData
        .uFlags = 0
    End With
    Shell_NotifyIcon NIM_DELETE, TheData
    
    ' 恢复原始窗口进程
    SetWindowLong TheForm.hwnd, GWL_WNDPROC, OldWindowProc
End Sub

' 设置图标提示
Public Sub SetTrayTip(tip As String)
    With TheData
        .szTip = tip & vbNullChar
        .uFlags = NIF_TIP
    End With
    Shell_NotifyIcon NIM_MODIFY, TheData
End Sub

' 设置托盘图标
Public Sub SetTrayIcon(pic As Picture)
    '系统闲时检测是否为图标
    If pic.Type <> vbPicTypeIcon Then Exit Sub

    ' 更新托盘图标
    With TheData
        .hIcon = pic.Handle
        .uFlags = NIF_ICON
    End With
    Shell_NotifyIcon NIM_MODIFY, TheData
End Sub