csystray.cls

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

End Property
Public Property Set SourceWindow(ByVal frmData As Form)

    'To do some of the work, we need to use the calling form.  This property sets
    'a link to that form
    Set frmSourceWindow = frmData
    SetPicHook
    
End Property
Public Property Get SourceWindow() As Form

    'Get the current form being used as the source
    Set SourceWindow = frmSourceWindow
    
End Property
Private Sub Class_Initialize()
    
    'This is run when the class is first instantiated.  It sets the defaults.
    bDefaultDblClk = True
    
    IconData.cbSize = Len(IconData)
    IconData.uId = 1&
    IconData.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    IconData.ucallbackMessage = WM_MOUSEMOVE
    IconData.hIcon = 0
    IconData.szTip = Chr$(0)       'Default to no tooltip
    
End Sub
Private Sub pbPictureHook_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    'This is where the true use of the pbPictureHook control comes in.  We use its
    'mouse move events to determine when the mouse button has been pressed over the
    'system tray icon.
    Static rec As Boolean
    Dim msg As Long
    Dim oldmsg As Long
    
    oldmsg = msg
    msg = X / Screen.TwipsPerPixelX
   
    If rec = False Then
        rec = True
        Select Case msg
            Case WM_LBUTTONDBLCLK:
                LButtonDblClk
            Case WM_LBUTTONDOWN:
                RaiseEvent LButtonDown
            Case WM_LBUTTONUP:
                RaiseEvent LButtonUp
            Case WM_RBUTTONDBLCLK:
                RaiseEvent RButtonDblClk
            Case WM_RBUTTONDOWN:
                RaiseEvent RButtonDown
            Case WM_RBUTTONUP:
                RaiseEvent RButtonUp
        End Select
        rec = False
    End If
    
End Sub
Private Sub LButtonDblClk()

    If bDefaultDblClk Then
        frmSourceWindow.WindowState = vbNormal
        frmSourceWindow.Show
        App.TaskVisible = True
        RemoveFromSysTray
    End If
    
    RaiseEvent LButtonDblClk
    
End Sub
Public Sub RemoveFromSysTray()
    
    'Remove the icon from the system tray.
    IconData.cbSize = Len(IconData)
    IconData.hwnd = pbPictureHook.hwnd
    IconData.uId = 1&
    
    Shell_NotifyIcon NIM_DELETE, IconData

End Sub
Public Sub IconInSysTray()
    
    'This simply adds the icon to the system tray without altering anything else.
    Shell_NotifyIcon NIM_ADD, IconData

End Sub
Public Sub MinToSysTray()
    
    'This method adds the icon to the system tray, but it also hides the calling form
    'and makes it invisible in the task bar.
    Me.IconInSysTray
    
    frmSourceWindow.Hide
    App.TaskVisible = False

End Sub
Private Sub SetPicHook()

    'This method creates a picture box at design time to be used as a hook.  We need
    'it to temporarily store the icon image and to record events.
    On Error GoTo AlreadyAdded
    
    Set pbPictureHook = frmSourceWindow.Controls.Add("VB.PictureBox", "pbPictureHook")

    pbPictureHook.Visible = False
    pbPictureHook.Picture = frmSourceWindow.Icon
    pbPictureHook.AutoRedraw = True
    pbPictureHook.AutoSize = True
    
    IconData.hwnd = pbPictureHook.hwnd
    
    Exit Sub

AlreadyAdded:
    If Err.Number <> 727 Then  ' pichook has already been added
       MsgBox "Run-time error '" & Err.Number & "':" & vbCrLf & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Error"
       Stop
       Resume
    End If

End Sub
Public Sub ChangeIcon(sIconPath As String)

    'This is where the beauty happens.  This is where we change the icon.  Anytime
    'ChangeIcon is called we are setting a new icon to be used on the system tray.
    'If an "ani" file (animated cursor) is being sent we need to do things a little
    'differently.  I search EVERYWHERE for a way to do this and found nothing.  It took
    'me several days to come up with this method.  I am currently working on an even
    'better, more stream lined way, which will remove the need for the ImageList
    'control.
    'If we are dealing with an ANI file, keep in mind that a new frame will be displayed
    'every subsequent call to ChangeIcon.  Therefore, to do the animation, you just need
    'to create your own timer that calls the ChangeIcon method with the ANI file path.

    Dim lResult As Long
    Dim liNewImage As ListImage
    
    'Kill the reference to the current icon.  Since we are about to create a link
    'to a new icon, we don't want a bunch of icons floating around in memory.
    DestroyIcon (IconData.hIcon)

    'Determine if we are dealing with an animated cursor or not
    If Right(sIconPath, 3) = "ani" Then
        'First we load the animated cursor into an icon handle
        IconData.hIcon = LoadImage(App.hInstance, sIconPath, IMAGE_CURSOR, 0, 0, LR_LOADFROMFILE)
        'Now we draw the current frame (which starts at 0) to the device context of
        'our picture box
        lResult = DrawIconEx(pbPictureHook.hdc, 0, 0, IconData.hIcon, 0, 0, iCurrentFrame, 0, DI_NORMAL)
        'lResult will = 1 if there is no problem, 0 if there is.  Err.LastDLLError will
        'be set with the value of any errors that occurr.  A 0 will be returned if that
        'frame does not exist in out ANI file.
        If lResult = 0 Then
            'Reset the frame counter to 0 and try again, if it fails again, we have
            'a real error that we need to trap and display.
            iCurrentFrame = 0
            lResult = DrawIconEx(pbPictureHook.hdc, 0, 0, IconData.hIcon, 0, 0, iCurrentFrame, 0, DI_NORMAL)
            If lResult = 0 Then
                MsgBox "[" & Err.LastDllError & "]  " & Err.Description, vbCritical And vbOKOnly, "Error Loading file"
                DestroyIcon (IconData.hIcon)
                End
            Else
                iCurrentFrame = iCurrentFrame + 1
            End If
        Else
            iCurrentFrame = iCurrentFrame + 1
        End If
        
        'This is where it gets a bit conviluted.  To get the icon image out of the
        'picture box's DC you use the image property.  However, this converts the icon
        'to a bitmap.  You can verify this by checking the picture object's "type"
        'property.  The only way I found to fix this problem, is by storing the
        'bitmap into an image list and using the ImageList's ExtractIcon method to
        'return and icon.  I will be changing this code soon to use the ImageList API
        'rather then relying on the actually control.
        pbPictureHook.Picture = pbPictureHook.Image
        Set liNewImage = frmDialupManage.ImageList1.ListImages.Add(1, "NEWICON", pbPictureHook.Picture)
        pbPictureHook.Picture = frmDialupManage.ImageList1.ListImages("NEWICON").ExtractIcon
        frmDialupManage.ImageList1.ListImages.Clear
        IconData.hIcon = pbPictureHook.Picture
    Else
        'Load the icon into an icon handle and store it in our structure
        IconData.hIcon = LoadImage(App.hInstance, sIconPath, IMAGE_ICON, 0, 0, LR_LOADFROMFILE)
    End If
    
    Shell_NotifyIcon NIM_MODIFY, IconData
    
End Sub
Public Sub ChangeToolTip(ByVal sNewTip As String)

    sToolTip = sNewTip
    IconData.szTip = sNewTip & Chr$(0)
    
    Shell_NotifyIcon NIM_MODIFY, IconData
    
    'If frmSourceWindow.WindowState = vbMinimized Then
    '    frmSourceWindow.Caption = sNewTip
    'End If
    
End Sub