'任务栏高度[此部分相关代码转载自 枕善居]
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<
/font>) 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


 
目前有1条回应
Comment
Trackback
Loading ....
  • Cavalry 回应于2009/12/27 21:47 回复TA

    3q,转走

    另外,这段代码弹出的窗体已被lz固定了长宽了.
    以下这段代码如果改为如下,即可自适应
    '确定位置
    Me.Move Screen.Width - Me.Width, Screen.Height - Me.Height - TaskbarHeight, _
    Me.Width, Me.Height

  • 本篇文章没有Trackback
你目前的身份是游客,请输入昵称和电邮!