DOS/V Power Report 2001 February/VPR0102A.BIN/PROGRAM/Module1.bas

BASIC Source File | 2000-11-18 | 20.2 KB | 748 lines

Attribute VB_Name = "Module1"
'---------------------------------------------------------
' ブロック消しゲーム
' All rights reserved. Copyright (c) Toshiya Moto, 2000.
'---------------------------------------------------------
Option Explicit

'ブロックマップファイル数
Private Const MAP_NUM = 3       '＝ステージ数

'ゲームエリアの定義
Private Const FIELD_PX = 8      'ゲームエリアの位置
Private Const FIELD_PY = 8      '  (X,Y)
Private Const FIELD_SX = 480    'ゲームエリアの大きさ
Private Const FIELD_SY = 304    '  (X,Y)

'パドルのデータ
Private Type TYPEPADL
    px  As Integer              'パドルの座標
    py  As Integer              '  (X,Y)
    sx  As Integer              'パドルの大きさ
    sy  As Integer              '  (X,Y)
End Type
Private paddle As TYPEPADL      'パドルのデータ

'ボールのデータ
Private Type TYPEBALL
    px  As Integer              'ボールの座標
    py  As Integer              '  (X,Y)
    sx  As Integer              'ボールの大きさ
    sy  As Integer              '  (X,Y)
    vx  As Integer              '移動ベクター
    vy  As Integer              '  (X,Y)
End Type
Private ball As TYPEBALL        'ボールのデータ

Private Const MV_VALUE = 5      'ボールの移動量

' マップ上のブロックの数
Private Const BLOCK_COL = 15    'ブロックの数
Private Const BLOCK_ROW = 10    '  (X,Y)

' ブロックのデータ
Private Type TYPEBLOCK
    px  As Integer              'ブロックの座標
    py  As Integer              '  (X,Y)
    sx  As Integer              'ブロックの大きさ
    sy  As Integer              '  (X,Y)
    broken As Boolean           '破壊されていたらTrue
    score As Integer            '破壊時の得点
    fontindex As Integer        'ブロックパターン
End Type
Private blocks(BLOCK_COL, BLOCK_ROW) As TYPEBLOCK
                                'ブロックのデータ配列

' ゲームの制御のための変数
Private nTotalBlock As Integer  'ブロックの総数
Private nStage As Integer       'ステージ番号
Private nBallNum As Integer     '持ちボール数
Private nScore As Integer       'スコア
Private nHighScore As Integer   'ハイスコア
Private boLostBall As Boolean   'ミスしたらTrue

'干渉コード
Private Const NO_INTERSECT = 0  '干渉していない
Private Const OVER_BOTTOM = 1   '下が干渉
Private Const OVER_TOP = 2      '上が干渉
Private Const OVER_LEFT = 4     '左が干渉
Private Const OVER_RIGHT = 8    '右が干渉
Private Const COMP_INSIDE = 15  '包含

'頂点包含コード
Private Const VTX_NONE = 0      '包含なし
Private Const VTX_LT = 1        '1点包含
Private Const VTX_RT = 2
Private Const VTX_LB = 4
Private Const VTX_RB = 8
Private Const VTX_LEFT = 5      '2点包含
Private Const VTX_TOP = 3
Private Const VTX_RIGHT = 10
Private Const VTX_BOTTOM = 12
Private Const VTX_ALL = 15      '4点包含

Public boPlaying As Boolean     'プレイ中を示すフラグ

'Win32 API宣言
Private Declare Function BitBlt Lib "gdi32.dll" (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 PlaySound Lib "winmm.dll" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long

Public Sub Main()
    SetupForm1          'Form1をセットアップする
End Sub

'Form1をセットアップする
Private Sub SetupForm1()
    Load Form1          'フォームをロード

    SetupScreens        'スクリーンを初期化
    SetupCombo1         '速度選択コンボを初期化

    nHighScore = 0      'ハイスコアをクリア
    Form1.lblhiscore.Caption = Format(nHighScore, "00000")

    GameInitialize      'ゲームを初期化する

    UpdateGameArea      'ゲームエリアを最新状態に更新

    Form1.Show          'フォームを表示
End Sub

'スクリーンを初期化する
Private Sub SetupScreens()
    'メインスクリーンを初期化する
    With Form1.mainscr
        .Left = FIELD_PX
        .Top = FIELD_PY
        .Width = FIELD_SX
        .Height = FIELD_SY
    End With

    'オフスクリーンを初期化する
    With Form1.offscr
        .Left = FIELD_PX
        .Top = FIELD_PY
        .Width = FIELD_SX
        .Height = FIELD_SY
        .BackColor = &HFFFFFF       '背景は白
    End With
End Sub

'ゲームエリアを最新状態に更新する
Private Sub UpdateGameArea()
    DrawPaddle True     'パドルを描画
    DrawBall True       'ボールを描画

    DrawGameArea        'ゲームエリアを描画
End Sub

'ゲームエリアを描画する
Private Sub DrawGameArea()
    Dim ret As Integer

    'オフスクリーンをメインスクリーンへ転送する
    ret = BitBlt(Form1.mainscr.hDC, 0, 0, FIELD_SX, FIELD_SY, Form1.offscr.hDC, 0, 0, vbSrcCopy)
    Form1.mainscr.Refresh
End Sub

'パドルを描画する
Private Sub DrawPaddle(disp As Boolean)
    Dim ret As Integer
    Dim pos As Integer

    '表示か消去かでパターンを切り替える
    pos = 0
    If Not disp Then
        pos = paddle.sy
    End If

    'パドルをオフスクリーンへ転送する
    With paddle
        ret = BitBlt(Form1.offscr.hDC, .px, .py, .sx, .sy, Form1.paddle.hDC, 0, pos, vbSrcCopy)
    End With
End Sub

'ボールを描画する
Private Sub DrawBall(disp As Boolean)
    Dim ret As Integer
    Dim pos As Integer

    '表示か消去かでパターンを切り替える
    pos = 0
    If Not disp Then
        pos = ball.sy
    End If

    'ボールをオフスクリーンへ転送する
    With ball
        ret = BitBlt(Form1.offscr.hDC, .px, .py, .sx, .sy, Form1.ball.hDC, 0, pos, vbSrcCopy)
    End With
End Sub

'ブロックを描画する
Private Sub DrawBlock(col As Integer, row As Integer)
    Dim ret As Integer
    Dim pos As Integer

    With blocks(col, row)
        If .broken Then     'ブロックが破壊されていたら
            pos = 8 * 16    '消去パターンにする
        Else
            pos = .fontindex * 16
        End If

        'ボールをオフスクリーンへ転送する
        ret = BitBlt(Form1.offscr.hDC, .px, .py, .sx, .sy, Form1.blocks.hDC, 0, pos, vbSrcCopy)
    End With
End Sub

'全ブロックを描画する
Private Sub DrawAllBlocks()
    Dim i As Integer
    Dim j As Integer

    'オフスクリーンを背景色で消去する
    With Form1.offscr
        .FillColor = vbWhite
        .FillStyle = vbFSSolid
        Form1.offscr.Line (-1, -1)-(.Width, .Height), , B
    End With

    '全部のブロックを順次描画する
    For j = 0 To BLOCK_ROW - 1
        For i = 0 To BLOCK_COL - 1
            DrawBlock i, j
        Next i
    Next j
End Sub

'パドルを移動する
Private Sub MovePaddle(mx As Integer)
    Dim xmin As Integer
    Dim xmax As Integer

    'パドルの移動可能範囲を求める
    xmin = 0
    xmax = FIELD_SX - paddle.sx

    'パドルの移動を制限する
    If mx < xmin Then
        mx = xmin
    End If
    If mx > xmax Then
        mx = xmax
    End If

    '古いパドルを消去する
    DrawPaddle False

    If Not boPlaying Then
        '古いボールを消去する
        DrawBall False
    End If

    '新しいパドル位置を計算する
    paddle.px = mx

    If Not boPlaying Then
        '新しいボール位置を計算する
        ball.px = paddle.px + (paddle.sx - ball.sx) / 2
    End If

    '表示を更新する
    UpdateGameArea
End Sub

'ボールを移動する
Private Sub MoveBall()
    Dim refrect As Boolean
    Dim action As Integer
    Dim ret As Long

    '古いボールを消去する
    DrawBall False

    refrect = True
    While (refrect)
        refrect = False

        '新しいボール位置を計算する
        ball.px = ball.px + ball.vx
        ball.py = ball.py + ball.vy

        'ボールの壁干渉判定
        action = TestBallWithWall
        If (action = NO_INTERSECT) Then
            'ボールのパドル干渉判定
            action = TestBallWithPaddle
            If (action = NO_INTERSECT) Then
                'ボールのブロック干渉判定
                action = TestBallWithAllBlocks
                If (action <> NO_INTERSECT) Then
                    'ボールが壁と干渉していたら反射処理
                    DoBallWithAny (action)
                    refrect = True
                    '反射音
                    ret = PlaySound("Se_l043.wav", 0&, &H20001)
                End If
            Else
                'パドルに当たった位置で反射角度変更
                ChangeRefAngle
                refrect = True
                '反射音
                ret = PlaySound("Se_l044.wav", 0&, &H20001)
            End If
        Else
            'ボールが壁と干渉していたら反射処理
            DoBallWithAny (action)
            refrect = True
            If (boLostBall) Then
                'ミス音
                ret = PlaySound("Se_l047.wav", 0&, &H20001)
            Else
                '反射音
                ret = PlaySound("Se_l044.wav", 0&, &H20001)
            End If
        End If
    Wend

    '表示を更新する
    UpdateGameArea
End Sub

'速度選択コンボを初期化する
Private Sub SetupCombo1()
    With Form1.Combo1
        .AddItem ("LOW")
        .AddItem ("MID")
        .AddItem ("HIGH")
        .ListIndex = 0   '速度を、LOWに設定
    End With
End Sub

'ゲームを初期化する
Private Sub GameInitialize()
    boPlaying = False   'プレイ中ではない

    'ゲーム情報の初期化
    nStage = 0          'ステージ＃０から開始
    Form1.lblstage.Caption = Format(nStage + 1, "00")
    StageInitialize     'ステージを初期化する
    nScore = 0          '得点をクリア
    Form1.lblscore.Caption = Format(nScore, "0000")

    '全ブロックを描画する
    DrawAllBlocks
End Sub

'ステージを初期化する
Private Sub StageInitialize()
    Dim i As Integer
    Dim j As Integer

    'マップデータの初期化
    nTotalBlock = 0     '総ブロック数をクリア
    LoadBlockMap nStage 'ブロックマップファイルをロード

    SetupNextBall       '次のボールを用意する

    'ゲーム制御情報の初期化
    nBallNum = 3        '持ちボール数をセット
    Form1.lblball.Caption = Format(nBallNum, "0")
End Sub

'次のボールを用意する
Private Sub SetupNextBall()
    'パドルを初期化
    With paddle
        .sx = 40
        .sy = 8
        .px = 200
        .py = 256
    End With

    'ボールを初期化
    With ball
        .sx = 8
        .sy = 8
        .px = paddle.px + (paddle.sx - ball.sx) / 2
        .py = paddle.py - ball.sy
        .vx = MV_VALUE
        .vy = -MV_VALUE
    End With

    'ボールのミスをリセット
    boLostBall = False
End Sub

'ボールの壁干渉判定
Private Function TestBallWithWall() As Integer
    Dim action As Integer
    Dim X As Integer
    Dim Y As Integer

    action = NO_INTERSECT

    '下チェック
    Y = ball.py + ball.sy
    If (Y >= FIELD_SY) Then
        action = action Or OVER_BOTTOM
        boLostBall = True   'ミス
    End If

    '上チェック
    Y = ball.py
    If (Y <= 0) Then
        action = action Or OVER_TOP
    End If

    '右チェック
    X = ball.px + ball.sx
    If (X >= FIELD_SX) Then
        action = action Or OVER_RIGHT
    End If

    '左チェック
    X = ball.px
    If (X <= 0) Then
        action = action Or OVER_LEFT
    End If

    TestBallWithWall = action
End Function

'ボールのパドル干渉判定
Private Function TestBallWithPaddle() As Integer
    Dim action As Integer

    action = NO_INTERSECT

    'ボールがパドルの範囲内かチェック
    If (ball.px >= paddle.px) And (ball.px <= paddle.px + paddle.sx) Then
        If (ball.vy > 0) Then
            'パドルの上面で反射チェック
            If (ball.py + ball.sy >= paddle.py) And (ball.py < paddle.py) Then
                action = action Or OVER_BOTTOM
            End If
        Else
            'パドルの下面で反射チェック
            If (ball.py <= paddle.py) And (ball.py + ball.sy > paddle.py) Then
                action = action Or OVER_TOP
            End If
        End If
    End If

    TestBallWithPaddle = action
End Function

'ボールがパドルのどの位置にあるかで反射角度を変える
Private Sub ChangeRefAngle()
    Dim org As Single
    Dim span As Single
    Dim bx As Single

    org = paddle.px
    bx = ball.px + (ball.sx / 2)
    span = paddle.sx / 10
    If (bx < org + span * 2) Then
        ball.vx = -MV_VALUE
        ball.vy = -(MV_VALUE / 2 + 1)
    Else
        If (bx < org + span * 4) Then
            ball.vx = -MV_VALUE
            ball.vy = -MV_VALUE
        Else
            If (bx < org + span * 5) Then
                ball.vx = -(MV_VALUE / 2 + 1)
                ball.vy = -MV_VALUE
            Else
                If (bx < org + span * 6) Then
                    ball.vx = (MV_VALUE / 2 + 1)
                    ball.vy = -MV_VALUE
                Else
                    If (bx < org + span * 8) Then
                        ball.vx = MV_VALUE
                        ball.vy = -MV_VALUE
                    Else
                        ball.vx = MV_VALUE
                        ball.vy = -(MV_VALUE / 2 + 1)
                    End If
                End If
            End If
        End If
    End If

End Sub

'点がブロック内かを判定
Private Function IsPtInBlock(blk As TYPEBLOCK, tx As Integer, ty As Integer) As Boolean
    IsPtInBlock = False
    With blk
        If (.px <= tx) And (.py <= ty) And (tx <= .px + .sx) And (ty <= .py + .sy) Then
            IsPtInBlock = True
        End If
    End With
End Function

'ボールのどの頂点がブロック内に包含しているか調べる
Private Function TestVertex(blk As TYPEBLOCK) As Integer
    TestVertex = VTX_NONE

    With ball
        '左上点の包含
        If IsPtInBlock(blk, .px, .py) Then
            TestVertex = TestVertex Or VTX_LT
        End If

        '左下点の包含
        If IsPtInBlock(blk, .px, .py + .sy - 1) Then
            TestVertex = TestVertex Or VTX_LB
        End If

        '右上点の包含
        If IsPtInBlock(blk, .px + .sx - 1, .py) Then
            TestVertex = TestVertex Or VTX_RT
        End If

        '右下点の包含
        If IsPtInBlock(blk, .px + .sx - 1, .py + .sy - 1) Then
            TestVertex = TestVertex Or VTX_RB
        End If
    End With
End Function

'ボールのブロック干渉判定
Private Function TestBallWithBlock(blk As TYPEBLOCK) As Integer
    Dim vertex As Integer
    Dim action As Integer

    action = NO_INTERSECT

    With blk
        'ブロックが破壊されていたら処理しない
        If .broken Then
            Exit Function
        End If

        'ボールのどの頂点がブロックに包含されているかテスト
        vertex = TestVertex(blk)
        Select Case vertex
            Case VTX_LEFT:
                action = OVER_LEFT
            Case VTX_TOP:
                action = OVER_TOP
            Case VTX_RIGHT:
                action = OVER_RIGHT
            Case VTX_BOTTOM:
                action = OVER_BOTTOM
            Case VTX_LT:
                action = COMP_INSIDE
            Case VTX_RT:
                action = COMP_INSIDE
            Case VTX_LB:
                action = COMP_INSIDE
            Case VTX_RB:
                action = COMP_INSIDE
            Case VTX_ALL:
                action = COMP_INSIDE
            Case Else
                action = NO_INTERSECT
        End Select
    End With

    TestBallWithBlock = action
End Function

'ボールの全ブロック干渉処理
Private Function TestBallWithAllBlocks() As Integer
    Dim action As Integer
    Dim i As Integer
    Dim j As Integer

    action = NO_INTERSECT

    For j = 0 To BLOCK_ROW - 1
        For i = 0 To BLOCK_COL - 1
            action = TestBallWithBlock(blocks(i, j))
            If (action <> NO_INTERSECT) Then
                '干渉したブロックを消去
                blocks(i, j).broken = True      '破壊サイン
                nTotalBlock = nTotalBlock - 1   '総ブロック数
                DrawBlock i, j
                '得点を加算
                nScore = nScore + blocks(i, j).score
                Form1.lblscore.Caption = Format(nScore, "0000")
                Exit For
            End If
        Next i
        If (action <> NO_INTERSECT) Then
            Exit For
        End If
    Next j

    TestBallWithAllBlocks = action
End Function

'ボールの反射処理
Private Sub DoBallWithAny(action As Integer)
    'ボールが上下ラインにかかったとき
    If (action And OVER_TOP) Or (action And OVER_BOTTOM) Then
        ' ボールの上下ベクターを反転
        ball.vy = -ball.vy
    End If

    'ボールが左右ラインにかかったとき
    If (action And OVER_LEFT) Or (action And OVER_RIGHT) Then
        ' ボールの左右ベクターを反転
        ball.vx = -ball.vx
    End If
End Sub

'マップの行をブロックデータに設定する
Private Sub SetMapLine(row As Integer, mline As String)
    Dim col As Integer
    Dim mapchar As String

    For col = 0 To BLOCK_COL - 1
        '１ブロックのデータを設定する
        mapchar = Mid(mline, col + 1, 1)
        With blocks(col, row)
            .sx = 32
            .sy = 16
            .px = col * .sx
            .py = row * .sy
            If mapchar = "-" Then
                .broken = True  '最初から破壊されている
                .score = 0
                .fontindex = 8
            Else
                .broken = False
                .score = BLOCK_ROW + 1 - row
                .fontindex = CInt(mapchar)
                nTotalBlock = nTotalBlock + 1
            End If
        End With
    Next col
End Sub

'ブロックマップファイルを読みこむ
Private Sub LoadBlockMap(mapno As Integer)
    Dim fs As Object
    Dim mapfile As Object
    Dim mapname As String
    Dim buff As String
    Dim row As Integer

    'ファイルを開く
    mapname = "Map" + CStr(mapno) + ".txt"
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set mapfile = fs.OpenTextFile(mapname)

    'マップファイルを1行づつ読む
    row = 0
    Do Until mapfile.AtEndOfStream
        buff = mapfile.ReadLine

        '読み込んだ1行をマップデータへ変換
        SetMapLine row, buff
        row = row + 1
    Loop

    'ファイルを閉じる
    mapfile.Close
    Set fs = Nothing
    Set mapfile = Nothing
End Sub

'メッセージウィンドウを表示する
Private Sub DispMsg(msgstr As String)
    'フォームの操作を禁止する
    Form1.Enabled = False

    'ダイアログを表示する
    Load Dialog         'ダイアログをロード
    Dialog.Label1.Caption = msgstr
    Dialog.Show         'ダイアログを表示
End Sub

'-----------------------------------------------------------------------
' インタフェース
'-----------------------------------------------------------------------

'インターバル処理
Public Sub TimerProc()
    'ボールを移動する
    MoveBall
End Sub

'ステージ開始処理
Public Sub StartStageProc()

End Sub

'ステージクリア処理
Public Sub ClearStageProc()
    '次のステージへ進む
    nStage = nStage + 1
    If (nStage < MAP_NUM) Then
        DispMsg "ステージをクリアしました."

        '次のステージの準備
        StageInitialize     'ステージを初期化する
    Else
        DispMsg "ゲームをクリアしました!!"

        'ハイスコアを更新
        If (nScore > nHighScore) Then
            nHighScore = nScore
            Form1.lblhiscore.Caption = Format(nHighScore, "00000")
        End If

        GameInitialize      'ゲームを初期化する
    End If
    Form1.lblstage.Caption = Format(nStage + 1, "00")

    DrawAllBlocks       '全ブロックを描画する
    UpdateGameArea      'ゲームエリアを最新状態に更新
End Sub

'ゲームオーバー処理
Public Sub GameOverProc()
    'ボール数を減らす
    nBallNum = nBallNum - 1
    Form1.lblball.Caption = Format(nBallNum, "0")
    If (nBallNum > 0) Then
        DispMsg "ミスしちゃいました."
        SetupNextBall       '次のボールを用意する
    Else
        DispMsg "ゲームオーバーです."

        'ハイスコアを更新
        If (nScore > nHighScore) Then
            nHighScore = nScore
            Form1.lblhiscore.Caption = Format(nHighScore, "00000")
        End If

        GameInitialize      'ゲームを初期化する
    End If

    DrawAllBlocks       '全ブロックを描画する
    UpdateGameArea      'ゲームエリアを最新状態に更新
End Sub

'ステージクリアかを調べる処理
Public Function IsClearStage() As Boolean
    IsClearStage = (nTotalBlock = 0)
End Function

'ゲームオーバーかを調べる処理
Public Function IsGameOver() As Boolean
    IsGameOver = boLostBall
End Function

'マウス移動処理
Public Sub MouseMoveProc(mx As Integer)
    'パドルを移動
    MovePaddle mx
End Sub