在调试本程序时，有一技巧值得说明的是：可将Form_Load 事件中Select Case …End Select语句稍作修改如下：
　　 a、将Case "/S" 注释掉， 在其下添加Case Else 语句；
　　 b、将Case Else/Unload Me/Exit Sub 三条语句注释掉；

　　 这样，可在VB5.0 环境下，调试本程序，预览演示效果。在调试完成后，再将上述修改恢复原样，编译成后缀为SCR的文件。

Option Explicit

'Declare API to inform system whether screen saver is active
Private Declare Function SystemParametersInfo Lib "user32" _
　　 Alias "SystemParametersInfoA" ( _
　　 ByVal uAction As Long, _
　　 ByVal uParam As Long, _
　　 ByVal lpvParam As Any, _
　　 ByVal fuWinIni As Long _
) As Long

'Declare API to hide or show mouse pointer
Private Declare Function ShowCursor Lib "user32" ( _
　　 ByVal bShow As Long _
) As Long

'Declare API to get a copy of entire screen
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

'Declare API to get handle to screen
Private Declare Function GetDesktopWindow Lib "user32" () As Long
'Declare API to convert handle to device context
Private Declare Function GetDC Lib "user32" ( _
　　 ByVal hwnd As Long _
) As Long

'Declare API to release device context
Private Declare Function ReleaseDC Lib "user32" ( _
　　 ByVal hwnd As Long, _
　　 ByVal hdc As Long _
) As Long

'Define constants
Const SPI_SETSCREENSAVEACTIVE = 17

'Define form-level variables
Dim QuitFlag As Boolean

Private Sub Form_Click()
　　 'Quit if mouse is clicked
　　 QuitFlag = True
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
　　 'Quit if keyboard is clicked
　　 QuitFlag = True
End Sub

Private Sub Form_Load()
　　 Dim X As Long, Y As Long
　　 Dim XScr As Long, YScr As Long
　　 Dim dwRop As Long, hwndSrc As Long, hSrcDc As Long
　　 Dim Res As Long
　　 Dim Count As Integer

　　 'Tell system that application is active now
　　 X = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, ByVal 0&, 0)
　　 'Hide mouse pointer
　　 X = ShowCursor(False)

　　 'Proceed based on command line
　　 Select Case UCase(Left(Command, 2))

　　 'Put the show on the load
　　 Case "/S"
　　　　 Randomize
　　　　 'Copy entire desktop screen into picture box
　　　　 Move 0, 0, Screen.Width + 1, Screen.Height + 1

　　　　 dwRop = &HCC0020
　　　　 hwndSrc = GetDesktopWindow()
　　　　 hSrcDc = GetDC(hwndSrc)
　　　　 Res = BitBlt(hdc, 0, 0, ScaleWidth, ScaleHeight, hSrcDc, 0, 0, dwRop)
　　　　 Res = ReleaseDC(hwndSrc, hSrcDc)

　　　　 'Display full size
　　　　 Show

　　　　 Form1.AutoRedraw = False
　　　　 'Graphics loop
　　　　 Do
　　　　　　 Count = 0
　　　　　　 X = Form1.ScaleWidth * Rnd
　　　　　　 Y = Form1.ScaleHeight * Rnd

　　　　　　 Do
　　　　　　　　 X = Form1.ScaleWidth * Rnd
　　　　　　　　 Y = Form1.ScaleHeight * Rnd

　　　　　　　　 DoEvents

　　　　　　　　 Form1.FillColor = QBColor(Int(Rnd * 15) + 1)
　　　　　　　　 Circle (X, Y), Rnd * 80, Form1.FillColor
　　　　　　　　 Count = Count + 1

　　　　　　　　 'Exit this loop only to quit screen saver
　　　　　　　　 If QuitFlag = True Then Exit Do

　　　　　　　　 'Move picture
　　　　　　　　 Dim Right As Boolean
　　　　　　　　 If Picture1.Left > 10 And Not Right Then
　　　　　　　　　　 Picture1.Left = Picture1.Left - 10
　　　　　　　　 Else
　　　　　　　　　　 Right = True
　　　　　　　　　　 If Picture1.Left < 7320 Then
　　　　　　　　　　　　 Picture1.Left = Picture1.Left + 10
　　　　　　　　　　 Else
　　　　　　　　　　　　 Right = False
　　　　　　　　　　 End If
　　　　　　　　 End If
　　　　　　　　 If (Count Mod 100) = 0 Then
　　　　　　　　　　 Form1.ForeColor = QBColor(Int(Rnd * 15) + 1)
　　　　　　　　　　 Print "Baby, I love you!"
　　　　　　　　 End If

　　　　　　 Loop Until Count > 500
　　　　　　 Form1.Cls

　　　　 Loop Until QuitFlag = True

　　　　 tmrExitNotify.Enabled = True
　　 Case Else
　　　　 Unload Me
　　　　 Exit Sub
　　 End Select
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As
Single, Y As Single)
　　 Static XLast, YLast As Single
　　 Dim XNow, YNow As Single

　　 'Get current position
　　 XNow = X
　　 YNow = Y

　　 'On first move, simply record position
　　 If XLast = 0 And YLast = 0 Then
　　　　 XLast = XNow
　　　　 YLast = YNow
　　　　 Exit Sub
　　 End If

　　 'Quit only if mouse actually changes position
　　 If Abs(XNow - XLast) > 2 Or Abs(YNow - YLast) > 2 Then
　　　　 QuitFlag = True
　　 End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
　　 Dim X

　　 'Inform system that screen saver is now inactive
　　 X = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, ByVal 0&, 0)

　　 'Show mouse pointer
　　 X = ShowCursor(True)
End Sub

Private Sub tmrExitNotify_Timer()
　　 'Time to quit
　　 Unload Me
End Sub

 2/2   首页 上一页 1 2