taskform.ctl

模仿qq的自动隐藏功能 方便实用 短小精悍 可以

VERSION 5.00
Begin VB.UserControl TaskBar 
   BackColor       =   &H00808000&
   ClientHeight    =   2970
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5460
   InvisibleAtRuntime=   -1  'True
   ScaleHeight     =   2970
   ScaleWidth      =   5460
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1
      Left            =   4680
      Top             =   1560
   End
   Begin VB.Image Image1 
      Height          =   480
      Left            =   0
      Picture         =   "TaskForm.ctx":0000
      Top             =   0
      Width           =   480
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "Task Bar"
      Height          =   390
      Left            =   0
      TabIndex        =   0
      Top             =   720
      Width           =   660
   End
End
Attribute VB_Name = "TaskBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

' **********************************************************************
'  描  述：vb 实现qq的可以拖隐藏到屏幕四边的效果的控件
'  Play78.com : 网站导航，源码之家，绝对开源
'  海阔天空编写,有问题请上www.paly78.com 提
'  网址：http://www.play78.com/
'  QQ：13355575
'  e-mail:[e-mail]
'  开发时间:2005-7-3
' **********************************************************************
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long '用于获取鼠标位置
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1

Private Enum MoveActionEnum
  ToTop
  ToLeft
  ToBottom
  ToRight
End Enum

Private Type POINTAPI '存储鼠标位置的类型
        X As Long
        Y As Long
End Type
Dim frm As Object, MoveAction As MoveActionEnum

'缺省属性值:
Const m_def_MoveLength = 500
Const m_def_GoLeft = 1
Const m_def_GoTop = 1
Const m_def_GoRight = 1
Const m_def_GoBottom = 1
Const m_def_OnTop = 0
'属性变量:
Dim m_MoveLength As Long
Dim m_GoLeft As Boolean
Dim m_GoTop As Boolean
Dim m_GoRight As Boolean
Dim m_GoBottom As Boolean
Dim m_OnTop As Boolean



'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,500
Public Property Get MoveLength() As Long
  MoveLength = m_MoveLength
End Property

Public Property Let MoveLength(ByVal New_MoveLength As Long)
  m_MoveLength = New_MoveLength
  PropertyChanged "MoveLength"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,1
Public Property Get GoLeft() As Boolean
  GoLeft = m_GoLeft
End Property

Public Property Let GoLeft(ByVal New_GoLeft As Boolean)
  m_GoLeft = New_GoLeft
  PropertyChanged "GoLeft"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,1
Public Property Get GoTop() As Boolean
  GoTop = m_GoTop
End Property

Public Property Let GoTop(ByVal New_GoTop As Boolean)
  m_GoTop = New_GoTop
  PropertyChanged "GoTop"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,1
Public Property Get GoRight() As Boolean
  GoRight = m_GoRight
End Property

Public Property Let GoRight(ByVal New_GoRight As Boolean)
  m_GoRight = New_GoRight
  PropertyChanged "GoRight"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,1
Public Property Get GoBottom() As Boolean
  GoBottom = m_GoBottom
End Property

Public Property Let GoBottom(ByVal New_GoBottom As Boolean)
  m_GoBottom = New_GoBottom
  PropertyChanged "GoBottom"
End Property


'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get OnTop() As Boolean
  OnTop = m_OnTop
End Property

Public Property Let OnTop(ByVal New_OnTop As Boolean)
  m_OnTop = New_OnTop
  If m_OnTop = True Then SetWindowPos frm.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Else SetWindowPos frm.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
  PropertyChanged "OnTop"
End Property


'为用户控件初始化属性
Private Sub UserControl_InitProperties()
  m_MoveLength = m_def_MoveLength
  m_GoLeft = m_def_GoLeft
  m_GoTop = m_def_GoTop
  m_GoRight = m_def_GoRight
  m_GoBottom = m_def_GoBottom
  m_OnTop = m_def_OnTop
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
If frm Is Nothing Then Set frm = UserControl.Parent
If Ambient.UserMode = True Then Timer1.Enabled = True Else Timer1.Enabled = False
  m_MoveLength = PropBag.ReadProperty("MoveLength", m_def_MoveLength)
  m_GoLeft = PropBag.ReadProperty("GoLeft", m_def_GoLeft)
  m_GoTop = PropBag.ReadProperty("GoTop", m_def_GoTop)
  m_GoRight = PropBag.ReadProperty("GoRight", m_def_GoRight)
  m_GoBottom = PropBag.ReadProperty("GoBottom", m_def_GoBottom)
  m_OnTop = PropBag.ReadProperty("OnTop", m_def_OnTop)
  If m_OnTop = True Then SetWindowPos frm.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Else SetWindowPos frm.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE

End Sub

Private Sub UserControl_Resize()
UserControl.Height = 500: UserControl.Width = 500
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

  Call PropBag.WriteProperty("MoveLength", m_MoveLength, m_def_MoveLength)
  Call PropBag.WriteProperty("GoLeft", m_GoLeft, m_def_GoLeft)
  Call PropBag.WriteProperty("GoTop", m_GoTop, m_def_GoTop)
  Call PropBag.WriteProperty("GoRight", m_GoRight, m_def_GoRight)
  Call PropBag.WriteProperty("GoBottom", m_GoBottom, m_def_GoBottom)
  Call PropBag.WriteProperty("OnTop", m_OnTop, m_def_OnTop)
End Sub


Private Sub Timer1_Timer()
    Dim pCursor As POINTAPI
    GetCursorPos pCursor '获取当前鼠标位置
    If frm.Left < 15 * pCursor.X And 15 * pCursor.X < frm.Left + frm.Width And frm.Top - 50 < 15 * pCursor.Y _
        And 15 * pCursor.Y < frm.Top + frm.Height + 50 Then '复杂的判断过程，判断鼠标是否位于窗体区域内
        If frm.Left <= 0 Then MoveAction = ToLeft: If m_GoLeft = True Then Call DownForm
        If frm.Top <= 0 Then MoveAction = ToTop: If m_GoTop = True Then Call DownForm
        If frm.Left + frm.Width > Screen.Width + 10 Then MoveAction = ToRight: If m_GoRight = True Then Call DownForm
    Else
      If frm.Left <= 100 Then MoveAction = ToLeft:  If m_GoLeft = True Then Call UpForm
      If frm.Top <= 200 Then MoveAction = ToTop:  If m_GoTop = True Then Call UpForm
      If frm.Left + frm.Width >= Screen.Width - 10 Then MoveAction = ToRight:  If m_GoRight = True Then Call UpForm
    End If
End Sub

Private Sub UpForm() '窗体上移
On Error Resume Next
If (GetKeyState(vbKeyLButton) And &H8000) Then Exit Sub '鼠标按下
Select Case MoveAction
Case ToTop
    If frm.Top <= m_MoveLength + 50 - frm.Height Then
      frm.Top = 50 - frm.Height
      Exit Sub
    ElseIf frm.Top < 50 - frm.Height Then
      Exit Sub
    End If
    frm.Top = frm.Top - m_MoveLength
Case ToLeft
    If frm.Left <= m_MoveLength + 50 - frm.Width Then
      frm.Left = 50 - frm.Width
      Exit Sub
    ElseIf frm.Left < 50 - frm.Width Then
      Exit Sub
    End If
    frm.Left = frm.Left - m_MoveLength
Case ToRight
    If frm.Left > Screen.Width - m_MoveLength Then
      frm.Left = Screen.Width - 30
      Exit Sub
    End If
    frm.Left = frm.Left + m_MoveLength
    
End Select
End Sub

Private Sub DownForm() '窗体下移
On Error Resume Next
Select Case MoveAction
Case ToTop
    If frm.Top >= -m_MoveLength - 50 Then
      frm.Top = 10
      Exit Sub
    End If
    frm.Top = frm.Top + m_MoveLength
Case ToLeft
    If frm.Left >= -m_MoveLength - 150 Then
      frm.Left = -150
      Exit Sub
    End If
    frm.Left = frm.Left + m_MoveLength
Case ToRight
    If frm.Left <= Screen.Width - frm.Width + m_MoveLength + 150 Then
      frm.Left = Screen.Width - frm.Width + 150
      Exit Sub
    End If
    frm.Left = frm.Left - m_MoveLength
End Select
End Sub