VB实现QQ窗体自动吸附到屏幕边缘的效果

作者:admin 日期:2008-04-07

字体大小: 小中大

VB实现QQ窗体自动吸附到屏幕边缘的效果

添加一个timer控件，直接运行代码即可

Option Explicit

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Dim p As POINTAPI

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
Private Const HWND_TOPMOST = -1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1

Private Sub Form_Load()
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE Timer1.Interval = 100
Timer1.Enabled = True
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
GetCursorPos p
If Me.Top <= 0 Then
   If p.Y > Me.Height / 15 + Me.Top / 15 or p.X > Me.Width / 15 + Me.Left / 15 or p.X < Me.Left / 15 Then
     Me.Top = 0 - Me.Height + 50
   End If
   If p.X > Me.Left / 15 And p.X < Me.Left / 15 + Me.Width / 15 And p.Y < 3 Then
     Me.Top = 0
   End If
End If

If Me.Left <= 0 Then
   If p.Y > Me.Height / 15 + Me.Top / 15 or p.Y < Me.Top / 15 or p.X > Me.Width / 15 + Me.Left / 15 Then
     Me.Left = 0 - Me.Width + 50

   End If
   If p.X < 3 And p.Y > Me.Top / 15 And p.Y < Me.Height / 15 + Me.Top / 15 Then
     Me.Left = 0
   End If
End If

If Me.Left >= Screen.Width - Me.Width Then

   If p.Y > Me.Height / 15 + Me.Top / 15 or p.Y < Me.Top / 15 or p.X < Me.Left / 15 Then
     Me.Left = Screen.Width - 50

   End If
   If p.X > Screen.Width / 15 - 3 And p.Y > Me.Top / 15 And p.Y < Me.Height / 15 + Me.Top / 15 Then
     Me.Left = Screen.Width - Me.Width
   End If
End If

If Me.Top >= Screen.Height - Me.Height Then
   If p.Y > Me.Height / 15 + Me.Top / 15 or p.X > Me.Width / 15 + Me.Left / 15 or p.X < Me.Left / 15 Then
     Me.Top = Screen.Height + 50
   End If
   If p.X > Me.Left / 15 And p.X < Me.Left / 15 + Me.Width / 15 And p.Y > Screen.Height / 15 - 3 Then
     Me.Top = Screen.Height - Me.Height
   End If
End If

End Sub