::电驴基地:: - Powered by Discuz! Board

标题: VB-技巧屏幕右下角浮出式小消息窗口 [打印本页]

作者: 毛主席 时间: 2008-2-28 09:29 标题: VB-技巧屏幕右下角浮出式小消息窗口

不知从什么时候起，软件的弹出消息都不再喜欢用以前那种吓人一跳的MessageBox对话框了，而是改在屏幕右下角弹一个小消息窗口。自然令我也想在自己程序里做类似的东西，就制造出了这个。如果能加个窗体皮肤就更好了。
PS: 只要一个form贴进此代码，加入Timer1和Timer2两个控件。

'-------------------------------------------------------------
'透明
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Const WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2
Const LWA_COLORKEY = &H1
'延迟
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'最前
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_BOTTOM = 1
Private Const HWND_BROADCAST = &HFFFF&
Private Const HWND_DESKTOP = 0
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1
'可见区域
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Dim MyRect As Long
Dim MyRgn As Long
Dim X1 As Integer, Y1 As Integer
Dim X2 As Integer, Y2 As Integer
Dim OpenSpeed As Integer
Dim CloseSpeed As Integer
Dim WiteLong As Integer

Private Sub Form_Load()
'------------------------------------------------------------------
  OpenSpeed = 10       '出现时速度
  CloseSpeed = 10       '关闭时淡出的速度
  Timer1.Interval = 10 '出现时显示平滑度
  WiteLong = 30       '关闭前等待时间(秒),为0则不会自动关闭
'------------------------------------------------------------------

  Me.Move Screen.Width * 0.75, Screen.Height * 0.75, _
      Screen.Width \ 4, Screen.Height \ 4

  SetWindowPos Me.hWnd, HWND_TOPMOST, Me.Left \ Screen.TwipsPerPixelX, Me.Top \ Screen.TwipsPerPixelY, Me.Width, Me.Height, 1
  X1 = 0
  Y1 = Me.Width \ Screen.TwipsPerPixelX

  X2 = Me.Width \ Screen.TwipsPerPixelX
  Y2 = Me.Height \ Screen.TwipsPerPixelY - 1

  MyRect = CreateRectRgn(X1, Y1, X2, Y2)
  MyRgn = SetWindowRgn(Me.hWnd, MyRect, True)
End Sub
Private Sub Form_Unload(Cancel As Integer)
  Call CloseMe(1)  '以什么样的方式关闭自己，有 1-淡出和 2-收缩可选
  Call DeleteObject(MyRect)
End Sub

Private Sub Timer1_Timer()
  Y2 = Y2 - OpenSpeed

  If Y2 <= 0 Then
MyRect = CreateRectRgn(0, 0, Me.Width \ Screen.TwipsPerPixelX, Y2)
MyRgn = SetWindowRgn(Me.hWnd, MyRect, True)

Timer1.Enabled = False

'----------------------
If WiteLong <> 0 Then
   Timer2.Interval = 1000
   Timer2.Enabled = True
End If
  End If

  MyRect = CreateRectRgn(X1, Y1, X2, Y2)
  MyRgn = SetWindowRgn(Me.hWnd, MyRect, True)
End Sub
Private Sub Timer2_Timer()
  Static NL As Integer
  NL = NL + 1

  If NL >= WiteLong Then Unload Me

End Sub

'==============================================
'0 - 不使用卸载效果
'1 - 使用透明淡出效果
'2 - 使用收缩效果
'==============================================
Private Sub CloseMe(Optional N As Integer = 1)
Select Case N
  Case 0
Exit Sub
  Case 1
Dim rtn As Long

rtn = GetWindowLong(Me.hWnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong Me.hWnd, GWL_EXSTYLE, rtn

For I = 255 To 10 Step -10
   SetLayeredWindowAttributes Me.hWnd, 0, I, LWA_ALPHA
   DoEvents
   Sleep CloseSpeed
Next I
  Case 2
While Y2 < (Me.Height / Screen.TwipsPerPixelY)
   Y2 = Y2 + OpenSpeed
   MyRect = CreateRectRgn(X1, Y1, X2, Y2)
   MyRgn = SetWindowRgn(Me.hWnd, MyRect, True)
   Sleep OpenSpeed
Wend
  Case Else

End Select
End Sub

欢迎光临 ::电驴基地:: (https://www.cmule.com/)