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

Question

只需自己在窗体添加一个timer控件
Option ExplicitPrivate Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Dim p As POINTAPIPrivate 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 = &H1Private 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 IfIf 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 IfIf 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 IfIf 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 IfEnd Sub
 

Answer 1

收藏了,用了一下google的桌面搜索,有点感觉

Answer 2

[color=#FF00FF]好东西[/color]

Answer 3

这个实现的是标题栏上跑字儿~~~  跟广告似的效果Option Explicit
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
'设置标题栏文本背景
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private start As Boolean
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'获取当前鼠标位置
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 POINTAPIPrivate 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 = &H1Private Sub Form_Load()
   start = False   
   Form3.Show
   start = True
   DisPlay
End Sub
'标题栏跑字儿~
Sub DisPlay()   Dim WndDC As Long
   Dim TmpDC As Long
   Dim TxtDC As Long
   Dim BackDC As Long
   Dim dl As Long
   Dim i As Integer
   Dim hBit As Long, hBit1 As Long, hbit2 As Long
   Dim oldBit As Long, oldBit1 As Long, oldbit2 As Long
   
   WndDC = GetWindowDC(Form3.hwnd)
   TmpDC = CreateCompatibleDC(WndDC)
   BackDC = CreateCompatibleDC(WndDC)
   TxtDC = CreateCompatibleDC(WndDC)
   
   hBit = CreateCompatibleBitmap(WndDC, 360, 20)      '创建一幅位图
   hBit1 = CreateCompatibleBitmap(WndDC, 360, 20)
   hbit2 = CreateCompatibleBitmap(WndDC, 360, 20)
   
   oldBit = SelectObject(TmpDC, hBit)
   oldBit1 = SelectObject(TxtDC, hBit1)
   oldbit2 = SelectObject(BackDC, hbit2)
   
   dl& = BitBlt(BackDC, 0, 0, 360, 20, WndDC, 24, 2, vbSrcCopy)  '准备背景图象
   dl& = SetBkColor(TxtDC, vbBlack)                                               '标题栏字体背景
   dl& = SetTextColor(TxtDC, vbRed)
   
   Do
       For i = -150 To 360
            If Not start Then Exit Do
            dl& = BitBlt(TmpDC, 0, 0, 360, 20, BackDC, 0, 0, vbSrcCopy)
            dl& = TextOut(TxtDC, 0, 0, "第六期软件班4号作品 ", 28)  '自己添加自己的文本内容
            dl& = BitBlt(TmpDC, i, 2, 150, 15, TxtDC, 0, 0, vbSrcPaint)
            dl& = BitBlt(WndDC, 24, 2, 360, 20, TmpDC, 0, 0, vbSrcCopy)
            DoEvents
            Sleep 20      '延时
       Next
   Loop   dl& = SelectObject(BackDC, oldbit2)
   dl& = SelectObject(TxtDC, oldBit1)
   dl& = SelectObject(TmpDC, oldBit)
   
   dl& = DeleteObject(hbit2)
   dl& = DeleteObject(hBit1)
   dl& = DeleteObject(hBit)
   
   dl& = DeleteDC(TmpDC)
   dl& = DeleteDC(BackDC)
   dl& = DeleteDC(TxtDC)
End Sub