'任务栏高度[此部分相关代码转载自 枕善居]
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( ByVal uAction As Long , ByVal uParam As Long , ByRef lpvParam As Any, ByVal fuWinIni As Long ) As Long
Private Const SPI_GETWORKAREA = 48
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'透明
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则不会自动关闭
'------------------------------------------------------------------
'计算任务栏高
Dim lRes As Long
Dim rectVal As RECT
Dim TaskbarHeight As Integer
lRes = SystemParametersInfo(SPI_GETWORKAREA, 0 , rectVal, 0 )
TaskbarHeight = Screen.Height - rectVal.Bottom * Screen.TwipsPerPixelY
'确定位置
Me.Move Screen.Width * 0.75 , Screen.Height * 0.75 - TaskbarHeight, _
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