break.frm

breakthrough游戏(保持小球在屏幕上跳动)源程序

   End
End
Attribute VB_Name = "frmBreakThru"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'--------------------------------------------------
' Global constants and varaibles used within the
' game's main form.
'--------------------------------------------------

' Ball Information --------------------------------
Dim bmpBall As tBitMap

' The current ball speed
Dim XSpeed As Integer
Dim YSpeed As Integer

' The slowest allowable ball speed
Dim MinXSpeed As Integer
Dim MinYSpeed As Integer

' The units at which the ball speed can change
Dim SpeedUnit As Integer

' Either +1 or -1, determines the direction
' that the ball is moving
Dim Xdir As Integer
Dim YDir As Integer

' The starting position of the ball.
Dim XStartBall As Integer
Dim YStartBall As Integer

Dim NumBalls As Integer

' Paddle Information ------------------------------
Dim bmpPaddle As tBitMap

' The starting position of the paddle
Dim XStartPaddle As Integer
Dim YStartPaddle As Integer

' The current amount of "english" that the paddle
' will apply to the ball.
Dim PaddleEnglish As Integer

' The amount that the paddle will move.
Dim PaddleIncrement As Integer

' Block Information -------------------------------
Const BLOCKS_IN_ROW = 10
Const NUM_ROWS = 2
Const BLOCK_GAP = 3

' Strings that store game wave audio files in memory.
Dim wavPaddleHit As String
Dim wavBlockHit As String
Dim wavWall As String
Dim wavMissed As String
Dim wavSetup As String
Dim wavNewLevel As String

' Use JoyStick?
Dim UseJoystick As Integer

' Joystick Information
Dim JoyInfo As tJoyInfo
Dim JoyAtRestMin As Long
Dim JoyAtRestMax As Long

' Used when calling the two API functions below.
Const SECTION = "HiScore"
Const ENTRY = "Score"
Const INI_FILE = "BREAKTHR.INI"

Dim HiScore As Integer
Dim HiPlayer As String

' Boolean (True/False) value that indicates if game
' has been paused.
Dim Paused As Integer

Private Sub Bitmap_Move(ABitMap As tBitMap, ByVal NewLeft As Integer, ByVal NewTop As Integer, SourcePicture As PictureBox)
'--------------------------------------------------
' This routine uses the BitBlt API function to
' first remove a bitmap from its original location
' (by simply BitBlting a black rectangle over its
' current position), then BitBlting the picture
' to its new location.
'--------------------------------------------------
Dim retcode As Integer

    ' Cover the image with a black rectangle, erasing it.
    retcode = BitBlt(picField.hDC, ABitMap.Left, ABitMap.Top, ABitMap.Width, ABitMap.Height, picBlack.hDC, 0, 0, SRCCOPY)

    ' Update the images location in its data structure.
    ABitMap.Left = NewLeft
    ABitMap.Top = NewTop

    ' Redisplay it at its new location.
    retcode = BitBlt(picField.hDC, ABitMap.Left, ABitMap.Top, ABitMap.Width, ABitMap.Height, SourcePicture.hDC, 0, 0, SRCCOPY)
End Sub

Private Function BlockCollided(A As tBitMap, B As Image) As Integer
'--------------------------------------------------
' Check if the bitmap, A, and the image control, B,
' overlap each other.
'--------------------------------------------------
Dim ACenterY As Integer
Dim BCenterY As Integer

Dim ACenterX As Integer
Dim BCenterX As Integer

    ACenterY = (A.Height \ 2) + A.Top
    BCenterY = (B.Height \ 2) + B.Top

    ACenterX = (A.Width \ 2) + A.Left
    BCenterX = (B.Width \ 2) + B.Left

    BlockCollided = False

    ' See if they intersect in the same Y range
    If Abs(ACenterY - BCenterY) < ((A.Height + B.Height) \ 2) Then
        ' See if the intersect in the same X range
        If Abs(ACenterX - BCenterX) < ((A.Width + B.Width) \ 2) Then
            BlockCollided = True
        End If
    End If

End Function

Private Function Collided(A As tBitMap, B As tBitMap) As Integer
'--------------------------------------------------
' Check if the two rectangles (bitmaps) intersect,
' using the IntersectRect API call.
'--------------------------------------------------

' Although we won't use it, we need a result
' rectangle to pass to the API routine.
Dim ResultRect As tBitMap

    ' Calculate the right and bottoms of rectangles needed by the API call.
    A.Right = A.Left + A.Width - 1
    A.Bottom = A.Top + A.Height - 1

    B.Right = B.Left + B.Width - 1
    B.Bottom = B.Top + B.Height - 1

    ' IntersectRect will only return 0 (false) if the
    ' two rectangles do NOT intersect.
    Collided = IntersectRect(ResultRect, A, B)
End Function

Private Sub CreateBlocks()
'--------------------------------------------------
' Create all the imgBlock elements that we need.
'--------------------------------------------------
Dim i As Integer

    For i = 1 To (NUM_ROWS * BLOCKS_IN_ROW)
        Load imgBlock(i)
    Next
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'--------------------------------------------------
' All game play input is handled through the
' keyboard (left and right arrow keys).
'--------------------------------------------------
    Select Case KeyCode
        Case KEY_LEFT:
            ' Make sure we're not off the left side
            If (bmpPaddle.Left - PaddleIncrement) > 0 Then
                ' Move the paddle to the left.
                Bitmap_Move bmpPaddle, bmpPaddle.Left - PaddleIncrement, bmpPaddle.Top, picPaddle

                ' Discard any english the paddle might have had from the opposite direction.
                If PaddleEnglish > 0 Then PaddleEnglish = 0
                PaddleEnglish = PaddleEnglish - 1
            End If
        Case KEY_RIGHT:
            ' Make sure we're not off the right side.
            If (bmpPaddle.Left + bmpPaddle.Width + PaddleIncrement) < picField.ScaleWidth Then
                ' Move the paddle to the right.
                Bitmap_Move bmpPaddle, bmpPaddle.Left + PaddleIncrement, bmpPaddle.Top, picPaddle

                ' Discard any english the paddle might have had from the opposite direction.
                If PaddleEnglish < 0 Then PaddleEnglish = 0
                PaddleEnglish = PaddleEnglish + 1
            End If
    End Select
End Sub

Private Sub Form_Load()
'--------------------------------------------------
' Position the game form and initialize all game
' values
'--------------------------------------------------
Dim JoyXRange As Long
Dim JoyXCenter As Long
Dim rc As Integer
Dim ScoreStr As String

    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2

    ' Display the form.
    Me.Show

    InitGeneralGameData

    CreateBlocks

    ' Read the current High Score.
    HiScore = 0
    HiPlayer = "???"
    ScoreStr = Space$(25)
    rc = GetPrivateProfileString(SECTION, ENTRY, "", ScoreStr, Len(ScoreStr), INI_FILE)
    If rc > 0 Then
        ScoreStr = Left$(ScoreStr, rc)
        If IsNumeric(ScoreStr) Then HiScore = Val(ScoreStr)
        HiPlayer = Space$(255)
        rc = GetPrivateProfileString(SECTION, "Player", "", HiPlayer, Len(HiPlayer), INI_FILE)
        If rc > 0 Then
            HiPlayer = Left$(HiPlayer, rc)
        Else
            HiPlayer = "???"
        End If
    End If
    
    ' Set up the Joystick
    rc = GetJoyStickPos(JOYSTICK1, JoyInfo)
    JoyXRange = (JoyCaps.Xmax - JoyCaps.Xmin)
    JoyXCenter = JoyCaps.Xmin + (JoyXRange / 2)
    JoyAtRestMin = JoyXCenter - (JoyXRange * 0.08)
    JoyAtRestMax = JoyXCenter + (JoyXRange * 0.08)


    ' Boolean (True/False) value that indicates if game
    ' has been paused.
    Paused = False
End Sub

Private Sub Form_Paint()
'--------------------------------------------------
' Draw 3D effect around selected controls on form.
'--------------------------------------------------
Dim i As Integer

    On Error Resume Next
    ' Look at the tag fields of all controls
    For i = 0 To Me.Controls.Count - 1
        If InStr(UCase$(Me.Controls(i).Tag), "/3D/") Then
            Make3D Me, Me.Controls(i), BORDER_INSET
        ElseIf InStr(UCase$(Me.Controls(i).Tag), "/3DUP/") Then
            Make3D Me, Me.Controls(i), BORDER_RAISED
        End If
    Next
End Sub

Private Sub InitGeneralGameData()
'--------------------------------------------------
' Set up variables that don't change during game play.
'--------------------------------------------------
    
    ' Determine the ball's start position based on game board dimensions.
    XStartBall = (picField.ScaleWidth - picBall.ScaleWidth) / 2
    YStartBall = (picField.ScaleHeight) / 4

    ' Determine the paddle's start position based on game board dimensions.
    XStartPaddle = (picField.ScaleWidth - picPaddle.ScaleWidth) / 2
    YStartPaddle = picField.ScaleHeight - picPaddle.ScaleHeight

    ' Load all the Game sounds into memory.
    wavSetup = NoiseGet(App.Path & "\" & "setup.wav")
    wavPaddleHit = NoiseGet(App.Path & "\" & "paddle.wav")
    wavBlockHit = NoiseGet(App.Path & "\" & "blockhit.wav")
    wavWall = NoiseGet(App.Path & "\" & "wallhit.wav")
    wavMissed = NoiseGet(App.Path & "\" & "missed.wav")
    wavNewLevel = NoiseGet(App.Path & "\" & "newlevel.wav")
    
    ' Get Ball dimensions from the picBall control
    bmpBall.Left = XStartBall
    bmpBall.Top = YStartBall
    bmpBall.Width = picBall.ScaleWidth
    bmpBall.Height = picBall.ScaleHeight

    ' Get Paddle dimensions from the picPaddle control
    bmpPaddle.Left = XStartPaddle
    bmpPaddle.Top = YStartPaddle
    bmpPaddle.Width = picPaddle.ScaleWidth
    bmpPaddle.Height = picPaddle.ScaleHeight
                  
    ' Number of balls the user gets during the game.
    NumBalls = 4
End Sub

Private Sub InitNewGameData()
'--------------------------------------------------
' Set up all the variable we need for a new game.
'--------------------------------------------------

    ' Reset the score counting labels.
    lblHiScore = Format$(HiScore, "0000") & " - " & Trim$(HiPlayer)
    lblMisses = 0
    lblPoints = "0000"

    ' Turn off the "Game Over" sign.
    lblGameOver.Visible = False

    ' The slowest speed increment is one pixel.
    SpeedUnit = 1

    ' Set the minimum speed.
    MinXSpeed = SpeedUnit * 6
    MinYSpeed = MinXSpeed

    ' Initial Speed is as slow as allowable.
    XSpeed = MinXSpeed
    YSpeed = MinYSpeed