解説ページへ戻る

ベジェ曲線を使ったスクリーンセーバー

完成版の全コードと変更すべきプロパティなど

ここで掲載しているコードはほぼ解説どおりのコードですが、１部コードの順番などが変えてある部分もあります。これはコードを少しでも読みやすくしようとの配慮で、その動作や機能は解説しているものとまったく同じです。

なお、このコードは、リソースエディタが利用できる状況にある人を想定しています。もしリソースエディタが利用できない状況にある人は　'▼マウスポインタを透明にする　の直後の１行をコメントアウトして、さらにその下の１行のコメントをはずしてください。

　

標準モジュールの全コード

Option Explicit

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Const GWL_STYLE = (-16)
Private Const WS_CHILD = &H40000000
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Public PlayMode As String
Private Sub Main()

    Dim Opt As String           'コマンドラインを格納します。
    Dim ParentWnd As Long       'プレビュー時の親ウィンドウのハンドル
    Dim Style As Long
    Dim PreviewRect As RECT
    Dim Ret As Long
   
    '▼コマンドラインの取得
    Opt = Left(LTrim(Command), 2)

    Select Case Opt
        Case "/A", "/a"     '●パスワードチェックモード
           
        Case "/C", "/c"     '●設定モード
           
            MsgBox "自作スクリーンセーバー" & vbCrLf & vbCrLf & _
                    "提供　VISUAL BASIC中学校"
       
        Case "/P", "/p"     '●プレビューモード
           
            frmScreen.Caption = "SCREEN BY PREVIEW"
            PlayMode = "P"
           
            '▼プレビュー領域のハンドルを取得
            ParentWnd = Val(Mid(Command, 4))
           
            '▼プレビュー領域の座標を取得
            Call GetWindowRect(ParentWnd, PreviewRect)
   
            '▼フォームのサイズをプレビュー領域のサイズに合わせる。
            frmScreen.Left = 0
            frmScreen.Top = 0
            frmScreen.Width = (PreviewRect.Right - PreviewRect.Left) * Screen.TwipsPerPixelX
            frmScreen.Height = (PreviewRect.Bottom - PreviewRect.Top) * Screen.TwipsPerPixelY
       
            '▼フォームをプレビュー領域の子ウィンドウにする。
            Style = GetWindowLong(frmScreen.hwnd, GWL_STYLE)
            Ret = SetWindowLong(frmScreen.hwnd, GWL_STYLE, Style Or WS_CHILD)
            Ret = SetParent(frmScreen.hwnd, ParentWnd)
       
            '▼フォームを表示
            frmScreen.Show
           
        Case "/S", "/s"     '●通常モード
           
            '▼２重起動の防止
            If FindWindow(vbNullString, "SCREEN BY NORMAL") <> 0 Then End
            frmScreen.Caption = "SCREEN BY NORMAL"
            PlayMode = "S"
           
            '▼マウスポインタを透明にする
            frmScreen.MouseIcon = LoadResPicture(101, vbResCursor)
'frmScreen.MouseIcon = LoadPicture(App.Path & "\TransMs.Cur")
            frmScreen.MousePointer = 99
   
            '▼フォームを最大化して表示
            frmScreen.WindowState = 2
            frmScreen.Show
           
    End Select

End Sub		 
　

　

フォームの全コード

Option Explicit

Private Declare Function PolyBezier Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, ByVal cPoints As Long) As Long

Private Type POINTAPI
    X As Long
    Y As Long
End Type
'■BezierDance
'■機能  フォーム上にベジェ曲線を延々と描画する。
Private Sub BezierDance()

    Dim K As Integer
    Dim M As Integer
    Dim L As Integer
    Dim Pnt(3) As POINTAPI
    Dim Target As Integer
    Dim WaitTime As Single
    Dim RecTime As Single
    Dim XDistance As Long
    Dim YDistance As Long
   
    WaitTime = 0.01
  
    Do
   
    For M = 0 To 3
        Pnt(M).X = Randome(0, ScaleWidth \ 2)
        Pnt(M).Y = Randome(0, ScaleHeight \ 2)
    Next M
   
    Pnt(0).X = 0
    Pnt(0).Y = 0
    Pnt(3).X = ScaleWidth
    Pnt(3).Y = ScaleHeight
   
    For L = 1 To 100
   
        Me.ForeColor = RGB(255 - L, 255 * (L / 100), 255 * (L / 50))
       
        Target = Target + 1
        If Target = 3 Then Target = 1
        With Pnt(Target)
       
        '▼点の移動距離をランダムで決める
        XDistance = Randome(-20, 20)
        YDistance = Randome(-20, 20)
       
        For K = 1 To 40
           
            DoEvents   'これがないと描画中にイベントが発生しないので終了できない。
 
            '▼点の移動
            .X = .X + XDistance
            .Y = .Y + YDistance
       
            '▼画面から点がはみ出さないような配慮
            If .X > ScaleWidth Or .X < 0 Then XDistance = -XDistance
            If .Y > ScaleHeight Or .Y < 0 Then YDistance = -YDistance
       
            Call PolyBezier(Me.hdc, Pnt(0), 4)
           
            '▼時間をつぶす
            RecTime = Timer
            Do Until Timer - RecTime > WaitTime
                DoEvents
            Loop
   
        Next K
        End With
   
    Next L
   
    frmScreen.Cls
    Loop
   
End Sub
'■Randome
'■機能  指定された範囲でランダムな整数を生成する。
'■引数  Min     範囲の最小値
'■　　　Max     範囲の最大値
'■戻り値    生成されたランダムな整数
Private Function Randome(Min As Long, Max As Long) As Long

    Randomize
    Randome = Fix(Rnd() * (Max - Min + 1)) + Min

End Function
Private Sub Form_Click()

    If PlayMode = "S" Then End

End Sub
Private Sub Form_Paint()

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

    If PlayMode = "S" Then End

End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Static IsSecond As Boolean  '初回は何もせず終了するためのフラグ
    Static LastX As Long        '前回のマウスのＸ座標を記録
    Static LastY As Long        '前回のマウスのＹ座標を記録
   
   
    If IsSecond = False Then        '初回は何もせずに終了
        LastX = X
        LastY = Y
        IsSecond = True
    Else
        If PlayMode = "S" Then      '通常モードで一定距離以上動いていたら終了
            If Abs(X - LastX) > 10 And Abs(Y - LastY) > 10 Then
                End
            Else
                LastX = X
                LastY = Y
            End If
        End If
    End If

End Sub
Private Sub Form_Unload(Cancel As Integer)

    End

End Sub		 
　

　

変更すべきプロパティ

　

フォーム

オブジェクト名

frmScreen

BackColor

&H00000000&

BorderStyle

0 - なし

KeyPreview

True

ScaleMode

3 - ﾋﾟｸｾﾙ

　

その他変更すべき点

　

１．スタートアップの設定

内容：スタートアップを    Sub Main    にする。

その方法：

１．[プロジェクト]メニューをクリック

２．[Project1のプロパティ]をクリック

３．[全般]タブをクリック

４．「スタートアップの設定」欄で    Sub Main    を選択する

５．「ＯＫ」ボタンをクリック

２．透明なマウスアイコンの用意

内容：透明なマウスアイコンを用意する。

その方法：

①リソースエディタが利用できる場合の方法

１． TransMs.curをダウンロード

２．[アドイン]メニューをクリック

３．「リソースエディタ」を選択してロード

４．リソースエディタのアイコンをクリックして起動

５．マウスポインタを追加するアイコンをクリック

６．TransMs.curを選択

７．IDが 101 になっていることを確認。

②リソースエディタが利用できない場合の方法

１． TransMs.curをダウンロードする

２．プロジェクトを保存する

３．プロジェクトの保存先と同じフォルダにTransMs.curを配置する

　

コンパイル後の注意点

　

・生成されるファイルの拡張子を scr にする。

・scrファイルをWindowsフォルダに配置する。