vbtris32.bas

一个很好的VB程序

Attribute VB_Name = "VBtris"
'-------------------------------------------------------
'VBtris32
'Created by Eric Griffith
'This is freeware.  Feel free to distribute it.
'-------------------------------------------------------
Option Explicit
'-------------------------------------------------------
'This module contains all global declerations for the
'game and all the procedures used to run the game.
'-------------------------------------------------------

'-------------------------------------------------------
'This function is used to "paste" together the squares
'onto the gameboard to create what the player sees
'-------------------------------------------------------
Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer

'-------------------------------------------------------
'This constant is used with BitBlt for dwRop.  This
'tells it to copy the source image and paste it over
'the destination image at the prespecified coordinates
'-------------------------------------------------------
Global Const SRCCOPY = &HCC0020

'-------------------------------------------------------
'These functions are used to read and write to the
'program's .INI file
'-------------------------------------------------------
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

'-------------------------------------------------------
'This function the constants are used to play the game's
'sounds
'-------------------------------------------------------
Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Global Const NEXT_LEVEL = "Sound1.wav"
Global Const PIECE_STOP = "Sound2.wav"
Global Const PIECE_DOWN = "Sound3.wav"
Global Const ONE_LINE = "Sound4.wav"
Global Const TWO_LINES = "Sound5.wav"
Global Const THREE_LINES = "Sound6.wav"
Global Const FOUR_LINES = "Sound7.wav"

Global Const MUSIC = "VBtris32.mid"

'-------------------------------------------------------
'This is a type created to contain all the information
'used pertaining to the gameboard and the pieces on it
'except for a few boolean variables
'-------------------------------------------------------
Type GameBoard
    'Variable representation of the board the player sees
    Square(1 To 10, 1 To 18) As Integer
    'The hDc of the pictures containing the colored
    'square.  To be used with BitBlt
    PieceDC(0 To 7) As Integer
    'The number of lines the player has cleared
    Rows As Integer
    'What kind of piece is currently falling
    CurPiece As Integer
    'What kind of piece the next one will be
    NextPiece As Integer
    'What the X position of the piece is
    PieceX As Integer
    'What the Y position of the piece is
    PieceY As Integer
    'What the pieces orientation is (Pertaining to
    'rotation)
    PiecePos As Integer
    'The players score
    Score As Variant
    'The level the player is on
    Level As Integer
    'The hDc of the board the player sees
    BoardDC As Integer
    'The hDc of the board the player doesn't see
    B2DC As Integer
    'A boolean expression telling whether or not a game is
    'in progress
    Game As Integer
End Type
'-------------------------------------------------------
'Variables pertaining to what the board looks
'like and what it just looked like, whether or not a
'new piece is needed, whether or not the game is over,
'whether or not a piece's descent is being accelerated,
'the number of seconds to pause between downward
'movement of pieces, what Y position the accelerated
'descent of a piece began at, the names of the people
'with high scores and their scores, whether or not
'the game is paused, what level to start the games on,
'whether or not to fill in some of the bottom lines,
'whether or not to immediately hide frmSplash, and
'whether or not to play sounds.
'-------------------------------------------------------
Global Board As GameBoard, OldBoard As GameBoard, NewPiece, GameOver
Global FallPiece, PL, FallY, ScoreN(1 To 10), Scores(1 To 10)
Global PauseTheGame, StartingLevel, FillLines, HideSplash
Global PlaySounds, MIDITime
Sub CheckForHighScore()
'-------------------------------------------------------
'Reads in the list of high scores and then it
'checks to see if the score the player got in the game
'he or she just played is a high score.  If it is, the
'scores below it are moved down one place, the player's
'name is read in, the updated list is composed and
'written to the disk and the new list is displayed
'-------------------------------------------------------
Dim I, J, N
'Read in the high scores
GetScores
For I = 1 To 5
    'Checking for the score
    If Board.Score >= Scores(I) Then
        If I < 5 Then
            'Moving the scores and names down one place
            For J = 5 To I + 1 Step -1
                Scores(J) = Scores(J - 1)
                ScoreN(J) = ScoreN(J - 1)
            Next
        End If
        'Reading in the player's name
        N = InputBox("Congratulations!" & Chr$(13) & Chr$(10) & "You got a High Score!" & Chr$(13) & Chr$(10) & "Enter your name:", "Tetris")
        'Inserting the player's name and score
        Scores(I) = Board.Score
        ScoreN(I) = N
        'Writng the scores to disk and displaying them
        WriteScores
        DisplayHighScores
        Exit For
    End If
Next

End Sub

Sub CheckForRows()
'-------------------------------------------------------
'This procedure goes through the board and checks to
'see if the player as filled in any rows.  Any rows that
'were filled in are recorded and emptied, the nonfilled
'rows are collapsed down, it is determined if the
'player has advanced to another level, and points are
'awarded as necessary
'-------------------------------------------------------
Dim I, J, R, L, GoBackOne, RCount
ReDim Rows(1 To 18)
RCount = 0
'Record what the board looks like in case it changes
OldBoard = Board
For J = 18 To 1 Step -1
    'Checks to see if Row J is filled
    R = True
    For I = 1 To 10
        If Board.Square(I, J) = 0 Then
            R = False
            Exit For
        End If
    Next
    'If R is still True then the row is filled and it is
    'recorded
    Rows(J) = R
    If R Then
        'The filled row is then emptied
        RCount = RCount + 1
        For I = 1 To 10
            Board.Square(I, J) = 0
        Next
    End If
Next
'The board is drawn with the empty rows
DrawBoard
Pause 0.1
'Play the appropriate sounds
If PlaySounds Then
    If RCount = 1 Then
        PlayWAV ONE_LINE
    ElseIf RCount = 2 Then
        PlayWAV TWO_LINES
    ElseIf RCount = 3 Then
        PlayWAV THREE_LINES
    ElseIf RCount = 4 Then
        PlayWAV FOUR_LINES
    End If
End If
    
For L = 18 To 2 Step -1
    'If a row has just been collapsed, it goes over it
    'again to make sure an empty row has not been put in
    'its place
    If GoBackOne Then
        L = L + 1
        GoBackOne = False
    End If
    If Rows(L) Then
        'Record the board before the row is collapsed
        OldBoard = Board
        For J = L To 2 Step -1
            For I = 1 To 10
                'Collapse Row L
                Board.Square(I, J) = Board.Square(I, J - 1)
            Next
            Rows(J) = Rows(J - 1)
            GoBackOne = True
        Next
        Pause 0.1
        'Draw the board now that the row has been collapsed
        DrawBoard
    End If
Next
'Check to see if the player has advanced to the next level
If Board.Rows \ 10 < (Board.Rows + RCount) \ 10 Then
    'Play the sound if appropriate
    If PlaySounds Then PlayWAV NEXT_LEVEL
    Board.Level = Board.Level + 1
    If Board.Level <= 9 Then PL = PL - 0.0472
End If
'Adjust the rows cleared by the player as necessary
Board.Rows = Board.Rows + RCount
'Award points based on how many rows the player filled
'with the last piece they used and what level they are on
If RCount = 1 Then
    Board.Score = Board.Score + (50 * (Board.Level + 1))
ElseIf RCount = 2 Then
    Board.Score = Board.Score + (150 * (Board.Level + 1))
ElseIf RCount = 3 Then
    Board.Score = Board.Score + (500 * (Board.Level + 1))
ElseIf RCount = 4 Then
    Board.Score = Board.Score + (1000 * (Board.Level + 1))
End If

End Sub

Sub DisplayHighScores()
'-------------------------------------------------------
'Puts the data from the high scores arrays into labels
'on frmHighScore and then shows that form
'-------------------------------------------------------
Dim I
For I = 1 To 5
    'Put the name in frmHighScore.lblName
    frmHighScore.lblName(I) = ScoreN(I)
    'Put the score in frmHighScore.lblScore
    frmHighScore.lblScore(I) = Scores(I)
Next
'Display the form modally
frmHighScore.Show 1

End Sub


Sub DrawBoard()
'-------------------------------------------------------
'Go through what the board looks like (Board.Square) and
'compare it to what it looked like before any changes,
'if any, were made.  Where ever differences are found,
'the changes are drawn on the board the player doesn't
'see (frmVBtris.picBoard2).  This is done to save time
'rather than redrawing every square every time.  Once
'the changes are drawn on the hidden board, that whole
'board is pasted over the board the player does see
'(frmVBtris.picBoard).  The two board method is done to
'prevent flickering or domino effect drawing of the
'squares.
'-------------------------------------------------------
Dim I, J, Temp
For I = 1 To 10
    For J = 1 To 18
        'Check one square for differences
        If Board.Square(I, J) <> OldBoard.Square(I, J) Then
            'Draw that square onto the hidden board
            Temp = BitBlt(Board.B2DC, ((I - 1) * 16) + 1, ((J - 1) * 16) + 1, 16, 16, Board.PieceDC(Board.Square(I, J)), 0, 0, SRCCOPY)
        End If
    Next
Next
'Make sure picBoard.AutoRedraw isn't true or else
'the board will not appear
If frmVBtris.picBoard.AutoRedraw Then
    frmVBtris.picBoard.AutoRedraw = False
End If
'Draw the hidden board onto the visible board
Temp = BitBlt(Board.BoardDC, 0, 0, 160, 288, Board.B2DC, 1, 1, SRCCOPY)

End Sub


Sub DrawPiece()
'-------------------------------------------------------
'Positions a new piece at the top of the board.  If it
'is being transposed any existing squares, then the game
'is over
'-------------------------------------------------------

'Piece 1
'    Y
'    Y
'X O O O O
'    Y
'    Y


'Piece 2
'    Y
'  O Y
'X O O O X
'    Y
'    Y

'Piece 3
'    Y
'    Y O
'X O O O X
'    Y
'    Y