vbtris32.bas

一个很好的VB程序

                    Board.Square(Board.PieceX + 2, Board.PieceY + 1) = 3
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        ElseIf Board.PiecePos = 3 Then
            If Board.PieceX <= 8 Then
                If Board.Square(Board.PieceX + 2, Board.PieceY) = 0 And Board.Square(Board.PieceX, Board.PieceY + 1) = 0 Then
                    Board.Square(Board.PieceX - 1, Board.PieceY) = 0
                    Board.Square(Board.PieceX - 1, Board.PieceY + 1) = 0
                    Board.Square(Board.PieceX + 2, Board.PieceY) = 3
                    Board.Square(Board.PieceX, Board.PieceY + 1) = 3
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        ElseIf Board.PiecePos = 4 Then
            If Board.PieceX <= 9 Then
                If Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 0 And Board.Square(Board.PieceX + 1, Board.PieceY) = 0 And Board.Square(Board.PieceX + 1, Board.PieceY + 1) = 0 Then
                    Board.Square(Board.PieceX - 1, Board.PieceY - 1) = 0
                    For I = Board.PieceY - 1 To Board.PieceY + 1
                        If I <> Board.PieceY - 1 Then Board.Square(Board.PieceX, I) = 0
                        Board.Square(Board.PieceX + 1, I) = 3
                    Next
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        End If
    Case 4
        If Board.PiecePos = 1 Then
            If Board.PieceX <= 8 Then
                If Board.Square(Board.PieceX + 2, Board.PieceY) = 0 And Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 0 Then
                    Board.Square(Board.PieceX - 1, Board.PieceY - 1) = 0
                    Board.Square(Board.PieceX, Board.PieceY) = 0
                    Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 4
                    Board.Square(Board.PieceX + 2, Board.PieceY) = 4
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        ElseIf Board.PiecePos = 2 Then
            If Board.PieceX <= 8 Then
                If Board.Square(Board.PieceX + 1, Board.PieceY + 1) = 0 And Board.Square(Board.PieceX + 2, Board.PieceY) = 0 And Board.Square(Board.PieceX + 2, Board.PieceY - 1) = 0 Then
                    Board.Square(Board.PieceX, Board.PieceY) = 0
                    Board.Square(Board.PieceX, Board.PieceY + 1) = 0
                    Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 0
                    Board.Square(Board.PieceX + 2, Board.PieceY) = 4
                    Board.Square(Board.PieceX + 1, Board.PieceY + 1) = 4
                    Board.Square(Board.PieceX + 2, Board.PieceY - 1) = 4
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        End If
    Case 5
        If Board.PiecePos = 1 Then
            If Board.PieceX <= 8 Then
                If Board.Square(Board.PieceX + 1, Board.PieceY) = 0 And Board.Square(Board.PieceX + 2, Board.PieceY - 1) = 0 Then
                    Board.Square(Board.PieceX - 1, Board.PieceY) = 0
                    Board.Square(Board.PieceX, Board.PieceY - 1) = 0
                    Board.Square(Board.PieceX + 1, Board.PieceY) = 5
                    Board.Square(Board.PieceX + 2, Board.PieceY - 1) = 5
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        ElseIf Board.PiecePos = 2 Then
            If Board.PieceX <= 8 Then
                If Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 0 And Board.Square(Board.PieceX + 2, Board.PieceY) = 0 And Board.Square(Board.PieceX + 2, Board.PieceY + 1) = 0 Then
                    Board.Square(Board.PieceX, Board.PieceY) = 0
                    Board.Square(Board.PieceX, Board.PieceY - 1) = 0
                    Board.Square(Board.PieceX + 1, Board.PieceY + 1) = 0
                    Board.Square(Board.PieceX + 2, Board.PieceY) = 5
                    Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 5
                    Board.Square(Board.PieceX + 2, Board.PieceY + 1) = 5
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        End If
    Case 6
        If Board.PiecePos = 1 Then
            If Board.PieceX <= 8 Then
                If Board.Square(Board.PieceX + 2, Board.PieceY) = 0 And Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 0 Then
                    Board.Square(Board.PieceX - 1, Board.PieceY) = 0
                    Board.Square(Board.PieceX, Board.PieceY - 1) = 0
                    Board.Square(Board.PieceX + 2, Board.PieceY) = 6
                    Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 6
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        ElseIf Board.PiecePos = 2 Then
            If Board.PieceX <= 8 Then
                If Board.Square(Board.PieceX + 1, Board.PieceY + 1) = 0 And Board.Square(Board.PieceX + 2, Board.PieceY) = 0 And Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 0 Then
                    For I = Board.PieceY - 1 To Board.PieceY + 1
                        Board.Square(Board.PieceX, I) = 0
                        If I <> Board.PieceY Then Board.Square(Board.PieceX + 1, I) = 6
                    Next
                    Board.Square(Board.PieceX + 2, Board.PieceY) = 6
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        ElseIf Board.PiecePos = 3 Then
            If Board.PieceX <= 8 Then
                If Board.Square(Board.PieceX + 1, Board.PieceY + 1) = 0 And Board.Square(Board.PieceX + 2, Board.PieceY) = 0 Then
                    Board.Square(Board.PieceX - 1, Board.PieceY) = 0
                    Board.Square(Board.PieceX, Board.PieceY + 1) = 0
                    Board.Square(Board.PieceX + 2, Board.PieceY) = 6
                    Board.Square(Board.PieceX + 1, Board.PieceY + 1) = 6
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        ElseIf Board.PiecePos = 4 Then
            If Board.PieceX <= 9 Then
                If Board.Square(Board.PieceX + 1, Board.PieceY - 1) = 0 And Board.Square(Board.PieceX + 1, Board.PieceY) = 0 And Board.Square(Board.PieceX + 1, Board.PieceY + 1) = 0 Then
                    Board.Square(Board.PieceX - 1, Board.PieceY) = 0
                    For I = Board.PieceY - 1 To Board.PieceY + 1
                        If I <> Board.PieceY Then Board.Square(Board.PieceX, I) = 0
                        Board.Square(Board.PieceX + 1, I) = 6
                    Next
                    Board.PieceX = Board.PieceX + 1
                End If
            End If
        End If
    Case 7
        If Board.PieceX <= 8 Then
            If Board.Square(Board.PieceX + 2, Board.PieceY) = 0 And Board.Square(Board.PieceX + 2, Board.PieceY - 1) = 0 Then
                Board.Square(Board.PieceX, Board.PieceY - 1) = 0
                Board.Square(Board.PieceX, Board.PieceY) = 0
                Board.Square(Board.PieceX + 2, Board.PieceY) = 7
                Board.Square(Board.PieceX + 2, Board.PieceY - 1) = 7
                Board.PieceX = Board.PieceX + 1
            End If
        End If
End Select
'Draw the board
DrawBoard

End Sub

Sub NewGame()
'-------------------------------------------------------
'Initializes all variables to their starting values and
'then starts the game
'-------------------------------------------------------
Dim I, J, RndNum
Randomize
'Record what the board looks like so it can be cleared if
'a game was just played
OldBoard = Board
For I = 1 To 10
    For J = 1 To 18
        'Clear the board
        Board.Square(I, J) = 0
    Next
Next

'Get the hDc values of the squares
frmPics.Tetris0.AutoRedraw = True
Board.PieceDC(0) = frmPics.Tetris0.hDC
frmPics.Tetris0.AutoRedraw = False
frmPics.Tetris1.AutoRedraw = True
Board.PieceDC(1) = frmPics.Tetris1.hDC
frmPics.Tetris1.AutoRedraw = False
frmPics.Tetris2.AutoRedraw = True
Board.PieceDC(2) = frmPics.Tetris2.hDC
frmPics.Tetris2.AutoRedraw = False
frmPics.Tetris3.AutoRedraw = True
Board.PieceDC(3) = frmPics.Tetris3.hDC
frmPics.Tetris3.AutoRedraw = False
frmPics.Tetris4.AutoRedraw = True
Board.PieceDC(4) = frmPics.Tetris4.hDC
frmPics.Tetris4.AutoRedraw = False
frmPics.Tetris5.AutoRedraw = True
Board.PieceDC(5) = frmPics.Tetris5.hDC
frmPics.Tetris5.AutoRedraw = False
frmPics.Tetris6.AutoRedraw = True
Board.PieceDC(6) = frmPics.Tetris6.hDC
frmPics.Tetris6.AutoRedraw = False
frmPics.Tetris7.AutoRedraw = True
Board.PieceDC(7) = frmPics.Tetris7.hDC
frmPics.Tetris7.AutoRedraw = False
'Get the hDc values of the boards
Board.BoardDC = frmVBtris.picBoard.hDC
Board.B2DC = frmVBtris.picBoard2.hDC
'Clear all variables
Board.Rows = 0
Board.CurPiece = 0
Board.NextPiece = 0
Board.Score = 0
Board.Level = StartingLevel
Board.PiecePos = 0
Board.PieceX = 0
Board.PieceY = 0
'Tell it a game is now going on
Board.Game = True
'Tell it no pieces are falling rapidly
FallPiece = False
'Tell it the game is not paused
PauseTheGame = False
'Clear the labels on frmVBtris
frmVBtris.lblScore = 0
frmVBtris.lblLines = 0
frmVBtris.lblLevel = StartingLevel
'Initialize the pause length
PL = 0.5 - (0.0472 * StartingLevel)
FallY = 0
'Fill in lines if the option is set
If FillLines Then
    For I = 1 To 10
        For J = 1 To 18
            If J >= 10 Then
                RndNum = Int(Rnd * 30)
                If RndNum <= StartingLevel Then
                    Board.Square(I, J) = Int(Rnd * 7) + 1
                    DrawBoard
                    OldBoard = Board
                End If
            End If
        Next
    Next
End If
'Draw the Board
DrawBoard
'Initialize OldBoard
OldBoard = Board
'Start the game
VBtris32

End Sub

Sub Pause(LenOfTime As Variant)
'-------------------------------------------------------
'Pause for LenOfTime seconds or until the game is
'unpaused if it is paused.  Also, redraw the board if
'the form has been restored after being minimized
'-------------------------------------------------------
Dim X As Variant, OldWinState, Temp, T As Long
If FallPiece Then Exit Sub
X = Timer
OldWinState = frmVBtris.WindowState
Do While ((Timer - X < LenOfTime) And (Timer >= X)) Or (PauseTheGame)
    If PlaySounds And Timer - MIDITime >= 150 Or Timer - MIDITime < 0 Then
        If InStr(App.Path, " ") Then
            T = mciSendString("play " & Chr(34) & App.Path & "\" & MUSIC & Chr(34), 0&, 0, 0)
        Else
            T = mciSendString("play " & App.Path & "\" & MUSIC, 0&, 0, 0)
        End If
        MIDITime = Timer
    End If
    'This is here to prevent a delay from when the player
    'pushes down and when the piece begins to fall rapidly
    If FallPiece Or GameOver Then Exit Sub
    If PauseTheGame Then
        'Make sure the caption of the form says
        '" - Paused" if the game is paused
        If frmVBtris.Caption <> "VBtris32 - Paused" Then
            frmVBtris.Caption = "VBtris32 - Paused"
        End If
        If frmVBtris.WindowState <> OldWinState Then
            'Draw the hidden board onto the visible board
            Temp = BitBlt(Board.BoardDC, 0, 0, 160, 288, Board.B2DC, 0, 0, SRCCOPY)
        End If
        OldWinState = frmVBtris.WindowState
    End If
    DoEvents
Loop
'Change the caption back if it says " - Paused"
If frmVBtris.Caption = "VBtris32 - Paused" Then
    frmVBtris.Caption = "VBtris32"
End If
End Sub

Sub PlayWAV(WAVtoPlay As String)
'-------------------------------------------------------
'Plays the wav specified by WAVtoPlay if PlaySounds is
'true
'-------------------------------------------------------
'Prevent errors in case the WAVs aren't there
On Error Resume Next
Dim Temp
Const SYNC = 1
If PlaySounds Then
    Temp = sndPlaySound(App.Path & "\" & WAVtoPlay, SYNC)
End If

End Sub

Sub ReadINIFile()
'-------------------------------------------------------
'Reads the game options in from the INI file and creates
'an INI file if one doesn't exist
'-------------------------------------------------------
Dim AppName As String, CurSection As String
Dim SectionVal As String, FileName As String
Dim Temp
'Info needed to find the file and where in it to look
AppName = "VBtris32"
FileName = "VBtris32.ini"

'Read in the value for StartingLevel
CurSection = "Starting Level"
SectionVal = Space(1)
Temp = GetPrivateProfileString(AppName, CurSection, "", SectionVal, 2, FileName)
If SectionVal = " " Then
    GenerateINIFile
    StartingLevel = 0
Else
    StartingLevel = Val(SectionVal)
End If

'Read in the value for FillLines
CurSection = "Fill Lines"
SectionVal = Space(1)
Temp = GetPrivateProfileString(AppName, CurSection, "", SectionVal, 2, FileName)
If SectionVal = "T" Then
    FillLines = True
Else
    FillLines = False
End If

'Read in the value for PlaySound