screensaver.frm

很好的教程原代码！

VERSION 5.00
Begin VB.Form ScreenSaver 
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   6675
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5310
   ControlBox      =   0   'False
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   6675
   ScaleWidth      =   5310
   ShowInTaskbar   =   0   'False
   WindowState     =   2  'Maximized
   Begin VB.Timer tmrExitNotify 
      Interval        =   1000
      Left            =   240
      Top             =   0
   End
   Begin VB.PictureBox Picture1 
      AutoSize        =   -1  'True
      Height          =   6300
      Left            =   480
      ScaleHeight     =   6240
      ScaleWidth      =   4440
      TabIndex        =   0
      Top             =   240
      Width           =   4500
   End
End
Attribute VB_Name = "ScreenSaver"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
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

Private Declare Function ShowCursor Lib "user32" ( _
    ByVal bShow 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 GetDesktopWindow Lib "user32" () As Long

Private Declare Function GetDC Lib "user32" ( _
    ByVal hwnd As Long _
) As Long

Private Declare Function ReleaseDC Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal hdc As Long _
) As Long

Const SPI_SETSCREENSAVEACTIVE = 17
Dim QuitFlag As Boolean

Private Sub Form_Click()
'单击鼠标则退出
QuitFlag = True

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

'触动键盘事件则退出
QuitFlag = True

End Sub



Private Sub Form_Load()
Picture1.Picture = LoadPicture(App.Path + "\SCR.bmp")
    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

    '告诉系统，程序是否为active
    X = SystemParametersInfo( _
        SPI_SETSCREENSAVEACTIVE, 0, ByVal 0&, 0)
    
    '隐藏鼠标指针
    X = ShowCursor(False)
    
    Select Case UCase(Left(Command, 2))
    Case "/S"

        Randomize
        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
        ScreenSaver.AutoRedraw = False
        Do
            Count = 0
            X = ScreenSaver.ScaleWidth * Rnd
            Y = ScreenSaver.ScaleHeight * Rnd
            Do
                X = ScreenSaver.ScaleWidth * Rnd
                Y = ScreenSaver.ScaleHeight * Rnd
                DoEvents
                ScreenSaver.FillColor = QBColor(Int(Rnd * 15) + 1)
                Circle (X, Y), Rnd * 80, ScreenSaver.FillColor
                Count = Count + 1

                '退出循环
                If QuitFlag = True Then Exit Do

                '移动图片
                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
                    ScreenSaver.ForeColor = QBColor(Int(Rnd * 15) + 1)
                    Print "Baby, I love you!"
                End If
            Loop Until Count > 500

            ScreenSaver.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

    '获取当前位置
    XNow = X
    YNow = Y

    If XLast = 0 And YLast = 0 Then
        XLast = XNow
        YLast = YNow
        Exit Sub
    End If

    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
    X = SystemParametersInfo( _
        SPI_SETSCREENSAVEACTIVE, 1, ByVal 0&, 0)

    '显示鼠标指针
    X = ShowCursor(True)
End Sub

Private Sub tmrExitNotify_Timer()
    If QuitFlag = True Then
        Unload Me
    End If
End Sub