實(shí) 際 上 使 用Visual Basic 6.0 很 容 易 建 立 屏 幕 保 護(hù) 程 序。 任 何Visual Basic 應(yīng) 用 程 序 都 可 以 作 為 一 個(gè) 屏 幕 保 護(hù) 程 序 來 運(yùn) 行， 只 是 有 的 程 序 做 此 工 作 會(huì) 比 其 它 程 序 更 好 一 些。 要 想 使 自 己 的 應(yīng) 用 程 序 扮 演Windows 環(huán) 境 中 屏 幕 保 護(hù) 程 序 的 角 色， 需 要 將 該 程 序 作 為 一 個(gè) 屏 幕 保 護(hù) 程 序 來 編 譯。

     具 體 操 作： 從File 菜 單 上 選 定Make EXE File， 在Make EXE File 對(duì) 話 框 中 作 以 下 改 動(dòng)： 不 再 建 立 帶 擴(kuò) 展 名 為EXE 的 可 執(zhí) 行 文 件， 而 是 把 擴(kuò) 展 名 改 為SCR。

     下 面 具 體 探 討 了 如 何 利 用Visual Basic 6.0 設(shè) 計(jì) 屏 幕 保 護(hù) 程 序， 也 就 是 在 設(shè) 計(jì) 屏 幕 保 護(hù) 程 序 時(shí) 應(yīng) 注 意 的 幾 個(gè) 問 題：

1、 如 何 防 止 同 時(shí) 運(yùn) 行 屏 幕 保 護(hù) 程 序 的 兩 個(gè) 實(shí) 例
     Visual Basic 提 供 了 一 個(gè)App 對(duì) 象， 它 有 一 個(gè)PreInstance 屬 性， 如 果 當(dāng) 前Visual Basic 應(yīng) 用 程 序 的 一 個(gè) 實(shí) 例 已 經(jīng) 運(yùn) 行 時(shí)， 便 把 該 屬 性 設(shè) 置 為True， 從 而 避 免 同 時(shí) 運(yùn) 行 一 個(gè) 屏 幕 保 護(hù) 程 序 的 多 個(gè) 實(shí) 例。
     下 面 的 代 碼 展 示App.PreInstance 是 如 何 典 型 地 在 一 個(gè) 屏 幕 保 護(hù) 程 序 中 實(shí) 現(xiàn) 的。
                If App.PreInstance=True then
                        Unload Me
                        Exit Sub
                End If


     此 外， 還 有 一 種 更 好 的 方 法 可 以 避 免 同 時(shí) 運(yùn) 行 一 個(gè) 屏 幕 保 護(hù) 程 序 的 多 個(gè) 實(shí) 例。 使 用 一 個(gè) 通 知 操 作 系 統(tǒng) 已 經(jīng) 有 一 個(gè) 屏 幕 保 護(hù) 程 序 被 激 活 的Windows 95 API 函 數(shù)。 這 個(gè) 函 數(shù) 便 是SystemParametersInfo， 其 聲 明 如 下：
                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


    在 窗 體 加 載 事 件 的 開 始 調(diào) 用 一 次 這 個(gè) 函 數(shù) 并 在 窗 體 卸 載 事 件 期 間 再 調(diào) 用 一 次。 這 兩 個(gè) 調(diào) 用 必 須 成 對(duì) 出 現(xiàn) 并 且 二 者 必 須 在 屏 幕 保 護(hù) 程 序 的 執(zhí) 行 期 間 進(jìn) 行 調(diào) 用。

    以 下 是 在 窗 體 加 載 事 件 中 對(duì) 該 函 數(shù) 的 調(diào) 用：

      x=SystemParametersInfo(17,0,ByVal 0&,0)

    以 下 是 在 窗 體 卸 載 事 件 中 對(duì) 該 函 數(shù) 的 調(diào) 用：

      x=SystemParametersInfo(17,1,ByVal 0&,0)

2、 如 何 在 屏 幕 保 護(hù) 程 序 中 隱 藏 鼠 標(biāo) 光 標(biāo)
    ShowCursor API 函 數(shù) 允 許 在Visual Basic 應(yīng) 用 程 序 中 隱 藏 或 顯 示 鼠 標(biāo) 光 標(biāo)，Windows 通 過 更 改 它 所 維 護(hù) 的 一 個(gè) 變 量 中 的 計(jì) 數(shù) 跟 蹤 鼠 標(biāo) 光 標(biāo) 的 可 視 性， 每 次 用 參 數(shù) 值True 調(diào) 用ShowCursor 都 使 這 個(gè) 計(jì) 數(shù) 遞 增， 每 次 用 參 數(shù) 值False 調(diào) 用ShowCursor 都 使 這 個(gè) 計(jì) 數(shù) 遞 減， 如 果 該 計(jì) 數(shù) 為0 或 者 更 小， 鼠 標(biāo) 光 標(biāo) 自 動(dòng) 隱 藏 起 來。 以 下 是ShowCursor API 函 數(shù) 的 聲 明：
           Private Declare Function ShowCursor Lib "user32" ( _
                        ByVal bShow As Long _
                ) As Long
    下 面 是 兩 個(gè) 使 用ShowCursor 函 數(shù) 的 例 子。
        顯 示 鼠 標(biāo) 光 標(biāo)：
                Private Sub ShowMouse()
                        While ShowCursor(True)<=0
                        Wend
                End Sub
        隱 藏 鼠 標(biāo) 光 標(biāo)：
                Private Sub HideMouse()
                        While ShowCursor(False)>0
                        Wend
                End Sub


3、 如 何 檢 測(cè) 鼠 標(biāo) 的 移 動(dòng)
     MouseMove 事 件 用 來 檢 測(cè) 鼠 標(biāo) 的 移 動(dòng)， 當(dāng) 應(yīng) 用 程 序 啟 動(dòng) 時(shí) 甚 至 鼠 標(biāo) 實(shí) 際 上 并 未 移 動(dòng) 的 情 況 下，MouseMove 事 件 都 會(huì) 觸 發(fā) 一 次。 所 以 第 一 次 觸 發(fā)MouseMove 事 件 時(shí)， 只 是 記 錄 鼠 標(biāo) 當(dāng) 前 位 置， 僅 當(dāng) 鼠 標(biāo) 真 正 從 其 起 始 位 置 移 開 時(shí)， 才 終 止 屏 幕 保 護(hù) 程 序。 具 體 實(shí) 現(xiàn) 代 碼 如 下：
                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
    
                        ' 記 錄 當(dāng) 前 位 置
                        XNow = X
                        YNow = Y
    
   ' 第 一 次 觸 發(fā)MouseMove 事 件， 記 錄 當(dāng) 前 位 置
                        If XLast = 0 And YLast = 0 Then
                                XLast = XNow
                                YLast = YNow
                                Exit Sub
                        End If
    
' 僅 當(dāng) 鼠 標(biāo) 移 動(dòng) 足 夠 迅 速（ 一 次2 個(gè) 像 素 以 上） 才 恢 復(fù) 屏 幕
                        If Abs(XNow - XLast) > 2 Or Abs(YNow - YLast) > 2 Then
                                QuitFlag = True
                        End If
                End Sub


4、 如 何 檢 測(cè) 鼠 標(biāo) 單 擊
Form_Click 事 件 用 來 檢 測(cè) 鼠 標(biāo) 單 擊，F(xiàn)orm_Click 事 件 的 具 體 代 碼 如 下：

                Private Sub Form_Click()
                        ' 鼠 標(biāo) 單 擊， 結(jié) 束 屏 幕 保 護(hù) 程 序
                        QuitFlag=True
                End Sub

5、 如 何 檢 測(cè) 鍵 盤 的 活 動(dòng)
    Form_KeyDown 事 件 用 來 檢 測(cè) 鍵 盤 的 活 動(dòng)， 當(dāng) 按 下 任 何 一 個(gè) 鍵（ 包 括 換 檔 鍵） 時(shí)， 都 能 結(jié) 束 屏 幕 保 護(hù) 程 序。Form_KeyDown 事 件 的 具 體 代 碼 如 下：

                Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
                        ' 按 下 鍵 盤， 結(jié) 束 屏 幕 保 護(hù) 程 序
                        QuitFlag = True
                End Sub

6、 設(shè) 置 幾 個(gè) 重 要 屬 性
    Form 窗 體BorderStyle 為0-None，ControlBox 為False，KeyPreview 為True，MaxButton 和MinButton 為False，WindowState 為2-Maximized， 定 義 窗 體 級(jí) 變 量QuitFlag（Dim QuitFlag as Boolean）。
    Timer 控 件（ 在Form 窗 體 中）Enabled 屬 性 在 設(shè) 計(jì) 環(huán) 境 中 設(shè) 置 為False。

    下 面 有 一 個(gè) 完 整 的 屏 幕 保 護(hù) 程 序 實(shí) 例， 其 演 示 效 果 為： 把 當(dāng) 前 的 顯 示 復(fù) 制 到 一 個(gè) 全 屏 幕 的 窗 體 中， 然 后 隨 機(jī) 在 屏 幕 上 畫 一 些 實(shí) 心 彩 色 小 圓， 并 隨 機(jī) 顯 示 彩 色 字 樣"Baby,I loveyou!"。 同 時(shí)， 在 屏 幕 底 部 有 一 移 動(dòng) 的 圖 片 框， 可 以 在 設(shè) 計(jì) 環(huán) 境 中 添 加 自 己 喜 歡 的 圖 片， 例 如 可 設(shè) 計(jì) 為： 程 序 設(shè) 計(jì)： 李 波 濤。 在 本 屏 幕 保 護(hù) 程 序 中， 設(shè) 置Timer 控 件 的Name 屬 性 為tmrExitNotify； 另 外， 在 窗 體 底 部 添 加 一 個(gè)PictureBox 控 件， 設(shè) 置 其Name 屬 性 為picture1。

    在 調(diào) 試 本 程 序 時(shí)， 有 一 技 巧 值 得 說 明 的 是： 可 將Form_Load 事 件 中Select Case …End Select 語(yǔ) 句 稍 作 修 改 如 下：

     a、 將Case "/S" 注 釋 掉， 在 其 下 添 加Case Else 語(yǔ) 句；
     b、 將Case Else/Unload Me/Exit Sub 三 條 語(yǔ) 句 注 釋 掉；

     這 樣， 可 在VB 6.0 環(huán) 境 下， 調(diào) 試 本 程 序， 預(yù) 覽 演 示 效 果。 在 調(diào) 試 完 成 后， 再 將 上 述 修 改 恢 復(fù) 原 樣， 編 譯 成 后 綴 為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