VB6.0でスクリーンセーバーを作る方法 - テンプレート

◆概要

このページは、Visual Basic 6.0で、VB6.0でスクリーンセーバーを作る人のために、テンプレートを用意しました。パスワードモード、設定モード、プレビューモードにも対応しています。

このスクリーンセーバーは、画面に画像をランダムに表示します。

◆フォームの設計

メインとなるフォーム名をfrmSaverにする。
frmSaverのKeyPreviewプロパテイをTrueにする。
frmSaverのBoruderStyleを[0-なし]にする。
フォームにタイマー　tmrExitNotify　を配置し、Intervalプロパティを1000にする。
フォームにタイマー　tmrPicMove　を配置し、Intervalプロパティを3000にする。
フォームにピクチャボックス(PictureBox1)を配置し、AutoSizeプロパティをTrue、BorderStyleを0-なし、ScaleModeを3-ピクセルにする。
フォームにピクチャボックス(picLargeとpicSmall)を配置し、VisibleプロパティをFalseする。
Visua Basicのメニューから[プロジェクト]-[Project1のプロパティ]を選び、全般タブのスタートアップの設定でSub Mainを選択する。

picLargeの画像は、スクリーンセーバーに表示したい画像(192×138程度)を用意します。picSmallは、プレビューモード用で画像は、38×28ピクセル程度にし、それぞれPidtureプロパティで読み込んでおきます。

　このセーバーでは、通常モードのときには大きい画像(picLarege)を、プレビューモードでは小さい画像（picSmall）をPictureBox1に転送するようにプログラムします。

フォームの設計

なお、マウスカーソルを隠す部分は、開発時（デバッグ時）にはコメントアウトしておいた方いいでしょう。

◆標準モジュール

Option Explicit
'APIの宣言*****************************************************
'もっとも前面にあるウィンドウのハンドル取得
Declare Function GetForegroundWindow Lib "user32" () As Long
'レジストリオープン
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
    ByVal hKey As Long, _
    ByVal lpSubKey As String, _
    ByVal ulOptions As Long, _
    ByVal samDesired As Long, _
    phkResult As Long) As Long
'レジストリ読み出し
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
    "RegQueryValueExA" ( _
    ByVal hKey As Long, _
    ByVal lpValueName As String, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    lpData As Any, _
    lpcbData As Long _
    ) As Long
'レジストリクローズ
Declare Function RegCloseKey Lib "advapi32.dll" ( _
    ByVal hKey As Long _
    ) As Long
'パスワード設定ダイアログ呼び出し
Declare Sub PwdChangePassword Lib "mpr.dll" Alias "PwdChangePasswordA" ( _
    ByVal lpClassName As String, _
    ByVal hwnd As Long, _
    ByVal lpA As Long, _
    ByVal lpB As Long _
    )
'パスワード入力ダイアログ呼び出し
Declare Function VerifyScreenSavePwd Lib "password.cpl" ( _
    ByVal hwnd As Long _
    ) As Boolean
'システムパラメータ設定（スクリーンセーバ実行中の設定につかう。
'パスワード保護時にセキュリティ強化できる。）
'IMEの状態取得/設定にも利用できる。
Declare Function SystemParametersInfo Lib "user32" Alias _
            "SystemParametersInfoA" ( _
            ByVal uAction As Long, _
            ByVal uParam As Long, _
            lpvParam As Any, _
            ByVal fuWinIni As Long _
            ) As Long

'プレビュー関係のAPI*********************************************
'自分のフォームを子ウィンドウに設定するためのAPI
'ウィンドウスタイルの取得
Declare Function GetWindowLong Lib "user32" Alias _
   "GetWindowLongA" ( _
   ByVal hwnd As Long, _
   ByVal nIndex As Long _
   ) As Long
'ウィンドウスタイルの設定のためのAPI
Declare Function SetWindowLong Lib "user32" Alias _
    "SetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long _
    ) As Long
'親ウィンドウを設定
Declare Function SetParent Lib "user32" ( _
    ByVal hWndChild As Long, _
    ByVal hWndNewParent As Long _
    ) As Long
'指定ウィンドウと関係のあるウィンドウのハンドルの取得
Declare Function GetWindow Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal wCmd As Long _
    ) As Long
'指定されたタイトルのウィンドウを探す
'   lpClassNameは、Windowsのウインドウクラス名
'   lpWindowNameは、ウインドウのキャプション
'   lpClassNameにvbNullString(Cで言う"")を指定しておけば、
'   lpWindowNameのものを探してくれる
Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String _
    ) As Long

'メッセージ送信
Declare Sub PostMessage Lib "user32" Alias "PostMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long _
    )
'プレビューモードでの親ウィンドウサイズ取得のための
'API宣言と構造体の宣言
Declare Function GetWindowRect Lib "user32" ( _
   ByVal hwnd As Long, _
   lpRect As RECT _
   ) As Long
'API-GetWindowRectで使う定義型
Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
'マウスポインタを隠したり表示したりするためのAPI
Declare Function ShowCursor Lib "user32" ( _
            ByVal bShow As Long) As Long
' SystemParametersInfoで使う定義型
Type OsVersionInfo
    dwVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatform As Long
    szCSDVersion As String * 128
End Type
'OSVersionを調べるAPI
Declare Function GetVersionEx& Lib "kernel32" Alias "GetVersionExA" ( _
            lpStruct As OsVersionInfo)
'Top-MostにするAPI
Declare Function SetWindowPos Lib "user32" ( _
            ByVal h&, _
            ByVal hb&, _
            ByVal X&, _
            ByVal Y&, _
            ByVal cx&, _
            ByVal cy&, _
            ByVal f& _
            ) As Integer
'処理を遅らせるSleep-API
Declare Sub Sleep Lib "kernel32" ( _
    ByVal dwMilliseconds As Long)
'指定したURLを開くためのAPI
Declare Function ShellExecute Lib _
      "shell32.dll" Alias "ShellExecuteA" _
      (ByVal hwnd As Long, _
      ByVal lpOperation As String, _
      ByVal lpFile As String, _
      ByVal lpParameters As String, _
      ByVal lpDirectory As String, _
      ByVal nShowCmd As Long) As Long

'APIで使用する定数***********************************************
'   レジストリ関係
Public Const HKEY_CURRENT_USER = &H80000001
Public Const KEY_QUERY_VALUE = &H1
Public Const REG_DWORD = 4
Public Const ERROR_SUCCESS = 0&
'   SystemParametersInfo関係
Public Const SPI_SCREENSAVERRUNNING = 97&
Public Const SPIF_NOINIFILE = &H0
Public tmplng&

'   小窓表示関係
Public Const GWL_STYLE = (-16)
Public Const GW_OWNER = 4
Public Const WS_CHILD = &H40000000
Public Const WM_CLOSE = &H10
'   OSVersion関係
Private OsVers As OsVersionInfo
Public winOS&
'   SetWindowPos関係
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = 1
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_TOPMOST = -1

'スクリーンセーバ定数***********************************************
'スクリーンセーバタイトル（プレビューと通常の区別）
Public Const pcSAVER_TITLE = "Normal"
Public Const pcPREVW_TITLE = "Preview"
Public pbPWP As Integer     'パスワード使用フラグ
Public strStartStyle As String     '起動判別パラメータ

Private Sub Main()
    Dim ret As Long         '関数の戻り値用の変数
    Dim PreviewRect As RECT
    Dim Style As Long
    Dim ParentWnd As Long   'この変数に親ウィンドウのハンドルを入れる。
    Dim RetCd As Long       '関数の戻り値用変数
    Dim whWnd As Long       'ワーク変数
    Dim lwk As Long         'ワーク変数
    

    'パスワードを使うかどうかレジストリを調べる
    pbPWP = 0
    'レジストリオープン
    RetCd = RegOpenKeyEx(HKEY_CURRENT_USER, "Control Panel\desktop", _
                        0, KEY_QUERY_VALUE, whWnd)
    If RetCd = ERROR_SUCCESS Then
        'パスワード使用するかの設定値を読み出し
        RetCd = RegQueryValueEx(whWnd, "ScreenSaveUsePassword", _
                        0, REG_DWORD, lwk, 4)
        If RetCd = ERROR_SUCCESS Then
            'パスワード使用フラグ設定
            pbPWP = CInt(lwk)
        End If
        'レジストリクローズ
        RetCd = RegCloseKey(whWnd)
    End If
    
    '起動時のパラメータ判断
    '最初"/"を除いた部分を取り出し大文字に変換（大文字でも小文字でも対処するため）
    strStartStyle = UCase(Mid(Command, 2, 1))
    If strStartStyle = "" Then
        'ユーザーが.scrファイルを右クリックして、[構成]を選んだときは
        '設定モード
        strStartStyle = "C"
    End If
    'パラメータの種類により処理分岐
    Select Case strStartStyle
        Case "A"
            'パスワード設定モードの処理
            '呼び出しもとのウィンドウハンドル（起動時パラメータの第二引数）を求める
            whWnd = Val(Trim(Mid(Command, 3)))
            '第二引数がない時は、最前面にあるのウィンドウハンドルを求める
            If whWnd = 0 Then
                whWnd = GetForegroundWindow()
            End If
            'システム共通のパスワード設定ダイアログを呼び出す
            Call PwdChangePassword("SCRSAVE", whWnd, 0, 0)
            '終了
            Exit Sub
            
        Case "C"
            '設定のためのフォームを呼び出す処理
            'frmSetting.Show vbModal
            'ここではメッセージボックスを表示
            MsgBox "このスクリーンセーバーには設定できるオプションはありません。", _
                vbOKOnly + vbExclamation
            Exit Sub
        Case "P"
            'プレビュー（コンパネの小窓）表示
            'プレビューモードで起動されたときの処理
                                   
            ParentWnd = Val(Mid(Command, 4))
            Call GetWindowRect(ParentWnd, PreviewRect)
            
            'frmSaverフォームの設定
            With frmSaver
                .Left = 0
                .Top = 0
                .Caption = pcPREVW_TITLE    'キャプション設定
                'GetWindowRectで得られたRECT構造体の値がピクセル単位であるため
                ' Screen.TwipsPerPixelXをかけてTwipsでの値に変換する
                .Width = (PreviewRect.Right - PreviewRect.Left) _
                                            * Screen.TwipsPerPixelX
                .Height = (PreviewRect.Bottom - PreviewRect.Top) _
                                            * Screen.TwipsPerPixelY
            End With
            
            Style = GetWindowLong(frmSaver.hwnd, GWL_STYLE)
            ret = SetWindowLong(frmSaver.hwnd, GWL_STYLE, Style Or WS_CHILD)
            ret = SetParent(frmSaver.hwnd, ParentWnd)
                        
        Case "S"
            'スクリーンセーバ起動済（コンパネの小窓プレビュー以外）なら即終了
            If FindWindow(vbNullString, pcSAVER_TITLE) <> 0 Then
                Exit Sub
            End If
            
            '通常モードの処理
            Load frmSaver
            'frmSaverフォームの設定
            With frmSaver
                .WindowState = 2            'フォームを最大化
                .Caption = pcSAVER_TITLE    'キャプション設定
                .KeyPreview = True          'キーボード対策
            End With

            'マウスカーソルを消す.
            Do
            Loop Until ShowCursor(False) < -5

        Case Else
            'パラメーター異常のとき
            Exit Sub
    End Select
    
    '通常モードとプレビューモードのとき
    'frmSaverフォームの設定
    With frmSaver
        .BackColor = vbBlack        'バックカラーを黒に
        .Show    'スクリーンを表示
    End With
            
End Sub

Sub GetOSVersion32()
    OsVers.dwVersionInfoSize = 148&
    tmplng = GetVersionEx(OsVers)
    winOS = OsVers.dwPlatform
End Sub
Public Function Randome(Min As Long, Max As Long) As Long
'Min以上Max以下の整数をランダムで生成する関数
'picuterBoxを表示する位置を指定するために使用
    Randomize
    Randome = Fix(Rnd() * (Max - Min + 1)) + Min

End Function

◆メインとなる frmSaver のフォームモジュール

Option Explicit
Dim QuitFlag As Boolean '終了フラグ
'Mouse Move イベント用の変数
Private prevX As Integer
Private prevY As Integer
Private oPict As Object 'ダミーのPictureBox用の変数

Private Sub Form_Click()
'マウスでクリックされたとき
    '終了フラグをTrueに
    QuitFlag = True
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'何かキーが押されたとき
    '終了フラグをTrueに
    QuitFlag = True
End Sub

Private Sub Form_Load()
    
    'スクリーンセーバーを TOPMOST windowにする(タスクバーやその他を覆う)
    tmplng = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)

    'フォームでスクリーンを覆う
    Move 0, 0, Screen.Width, Screen.Height

    'Windows 2000/Xp/Vistaでは,パスワードプロテクトされていないとき、
    '最小サイズ(minimized)でスタートしてしまう。それを回避するための一行
    Me.WindowState = vbNormal
    
    'WindowsがNTタイプシステム(Windows NT, Windows 2000,Widnows Xpなど)で
    '動いているのかどうか調べる。
    GetOSVersion32
    
    'このアプリケーションがスクリーンセーバーであることをシステムに通知する。
    'これはWindows 95とWindows98で CTRL-ALT-DEL キーを無効にする。
    'Windows NT はシステムレベルでパスワード保護されたスクリーンセーバーを
    '取り扱うので、CTRL-ALT-DELキーの組み合わせは使用不能にすることができない。
    tmplng = SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1&, 0&, 0&)
    
    QuitFlag = False
    
    'ScaleMode をピクセルに設定します。
    ScaleMode = vbPixels
    
    'Picture1の設定
    With Picture1
        .ScaleMode = vbPixels   'ScaleMode をピクセルに設定
        .BorderStyle = 0        'なし
        .AutoSize = True
        '毎回同じ位置にならないよう、PicturBoxのスタート位置を乱数により決定する。
        .Left = Randome(0, Me.ScaleWidth - Picture1.ScaleWidth)
        .Top = Randome(0, Me.ScaleHeight - Picture1.ScaleHeight)
    End With
    
    'モードによって画像を入れ替える
    If strStartStyle = "P" Then    'プレビューモードのとき
        Picture1.Picture = picSmall
    Else                            '通常モード
        Picture1.Picture = picLarge

        'IME対策
        frmSaver.Show   'これがないとSetfocusはエラーになる
        'コントロールの動的追加
        'ダミーのPicrureBox IME対策のため
        Set oPict = Controls.Add("VB.PictureBox", "picDummy")
        With oPict
            .Left = -8000   'フォームの外へ放り出す
            .Top = 100
            .Width = 2000
            .Height = 400
            .Visible = True
            .IMEMode = 3    'IME をオフ固定にします。
	    .SetFocus       ’picDummyにフォーカス
        End With
    End If
    
    
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
                                                X As Single, Y As Single)
    If ((prevX = 0) And (prevY = 0)) Or _
            ((Abs(prevX - X) < 5) And (Abs(prevY - Y) < 5)) Then
        '少しのマウスの動きでは終了させない。
        prevX = X
        prevY = Y
        Exit Sub
    Else
        '終了FlagをTrueに
        QuitFlag = True
    End If
    
End Sub
Private Sub SaverEnd()
    'スクリーンセーバ終了処理
    Dim RetCd As Boolean
    'プレビュー（コンパネの小窓）の時は、何しない（終わらない）
    If strStartStyle = "P" Then
        Exit Sub
    End If
    'マウスカーソルを表示
    Do Until ShowCursor(True) >= 0
    Loop
    'パスワード使うことになっているか？
    If pbPWP <> 0 Then
        'パスワードの入力中に、[ALT]+[TAB]や[CTRL]+[ESC]などのキー入力で
        'アプリ切替が出来ない様にシステムにスクリーンセーバ実行中を認識させる。
        tmplng = SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1&, 0&, 0&)
        'パスワード入力ダイアログの呼び出し
        RetCd = VerifyScreenSavePwd(Me.hwnd)
        If RetCd Then
            'パスワードがあっていれば
            'システムにスクリーンセーバ終了の通知
            tmplng = SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0&, 0&, 0&)
            '閉じる
            Unload Me
        Else
            'パスワードが間違いの時は、マウスカーソルを再び消す
            Do Until ShowCursor(False) < 0
            Loop
        End If
    Else
        'パスワードを使わないときは、閉じる
        Unload Me
    End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
   Dim RetCd As Long
    'プレビュー（コンパネの小窓）表示が閉じられたときは、
    '終了をVBの親フォームに強引に通知し、完全に終了する。
    If strStartStyle = "P" Then
        '親フォームのハンドル取得
        RetCd = GetWindow(Me.hwnd, GW_OWNER)
        'メッセージ通知
        Call PostMessage(RetCd, WM_CLOSE, 0, 0)
    End If
    'マウスカーソルを表示する
    Do
    Loop Until ShowCursor(True) > 5
    'CTRL-ALT-DEL キーが無効のときは、それを有効にする。
    tmplng = SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0&, 0&, 0&)

End Sub

Private Sub tmrExitNotify_Timer()
    '終了処理監視用タイマー
    If QuitFlag = True Then
        Call SaverEnd
        Exit Sub
    End If

End Sub

Private Sub tmrPicMove_Timer()
    '画像を動かすためのタイマー
    
    Cls 'フォームをクリア
    '毎回同じ位置にならないよう、PicturBoxの位置を乱数により決定する。
    With Picture1
        .Left = Randome(0, Me.ScaleWidth - Picture1.ScaleWidth)
        .Top = Randome(0, Me.ScaleHeight - Picture1.ScaleHeight)
    End With
End Sub

▼ページトップへ

White Tiger

VB6.0でスクリーンセーバーを作る方法 - テンプレート

Link

design: TempNate