frmstris.frm

用VB编写的Tetris游戏

   
   ' next Start from which Level?
   StartLevel = (Level \ 3) * 3
   Level = StartLevel
   SetLevel
   
   ' turn everything off again to be on the save side
   tmrPlay.Enabled = False
   Tmr1.Enabled = False
   Playing = False
   chkBalls.Enabled = True
   cmdStartStop.Caption = "&Start"
End Sub
' Sets a certain level
Private Sub SetLevel()
   Static fout
   Dim X As Long, Y As Long
   Dim I As Long, vx2 As Long
   Dim T As String, R As String
   
   On Error GoTo SetLevelError:
   px2 = SLevel(Level).px2       ' get new width of playing field
   mTime = SLevel(Level).mTime   ' set mTime to start time (the higher, the slower)
   For Y = 0 To 21               ' get mField from Level-data
     R = SLevel(Level).R(Y)
     For X = 0 To px2
       mField(X, Y) = Val(Mid(R, X + 1, 1))
     Next X
   Next Y

SetLevelNext:
   On Error GoTo 0
   vx2 = (px2 - 1) * Gr          ' calc. size in pixels of curr. mField
   P1.Width = vx2 + 60           ' and set picturebox
   ShowField
   Width = P1.Left + P1.Width + 180
   lblLevel(0).Caption = Level: lblLevel(1).Caption = lblLevel(0).Caption
   lblSpeed(0).Caption = mTime: lblSpeed(1).Caption = lblSpeed(0).Caption
   Exit Sub
   
SetLevelError:
   ClsField                      ' generate a random mField in case of an error or all levels are done.
   Randomize
   For I = 0 To 9
     X = Int(Rnd(px2 - 1) * (px2 - 1)) + 1
     Y = 20 - Int(Rnd(10) * 10) + 1
     mField(X, Y) = 8
   Next I
   mTime = 950
   Resume SetLevelNext:

End Sub

' prepare next piece
Private Sub MakeNextObj()
   Dim I As Integer, X As Long, Y As Long

   Randomize Timer
   nxtobjnr = Int(Rnd(PieceMode) * PieceMode) + 1
   For I = 0 To 2
      nox(I + 1) = obj(nxtobjnr, I * 2)
      noy(I + 1) = obj(nxtobjnr, I * 2 + 1)
   Next I
   
   ' show in preview window(picturebox)
   P2.Cls
   For X = 1 To 4: For Y = 1 To 4
      DrawSquare P2.hDC, X * 16, Y * 16, 0
   Next Y: Next X
   For I = 0 To 3
      X = (nox(I) + 2) * 16
      Y = (noy(I) + 2) * 16
      DrawSquare P2.hDC, X, Y, nxtobjnr
   Next I
End Sub

' make ready for start
Private Sub MakeReady()
    MakeNextObj
    SetLevel
    lblScore(0).Caption = Score: lblScore(1).Caption = lblScore(0).Caption
    lblLines(0).Caption = 0: lblLines(1).Caption = lblLines(0).Caption
    TakeNextObj
End Sub

' next Level --> next piece at the top-middle
Private Sub NextLevel()
    Level = Level + 1: SetLevel: ox = px2 / 2: oy = 1
End Sub
' drop pieces (Obj) 1 position down
Private Sub ObjDown()
   oy = oy + 1          ' test next position
   CheckSituation
   If Stat = 1 Then
      If oy <= 2 Then GameOver: Exit Sub
      oy = oy - 1       ' couldn't go further --> keep previous pos.
      StoreField        ' and store it in mField (pieces remain there from now one)
      CheckLines          ' new full-linnes made?
      TakeNextObj       ' take already prepared next piece from preview
      Score = Score + 100
      lblScore(0).Caption = Score: lblScore(1).Caption = lblScore(0).Caption
      KeyPze = True
      vobjfl = 1
      DrawPiece
      vobjfl = 0
      tmrPlay.Interval = mTime
      Else
      DrawPiece
      vobjfl = 0
      End If
End Sub

' draw a piece (obj) in playing field
Private Sub DrawPiece()
   Dim I As Long
   
   If vobjfl = 0 Then ' clear previous position
      For I = 0 To 3: DrawSquare P1.hDC, vox(I) * 16, voy(I) * 16, 0: Next I
      End If
   For I = 0 To 3 ' draw new position
      DrawSquare P1.hDC, (ox + hox(I)) * 16, (oy + hoy(I)) * 16, objnr
      vox(I) = ox + hox(I): voy(I) = oy + hoy(I)
   Next I
   P1.Refresh
End Sub

' store a piece that got stuck and make it permanent
Private Sub StoreField()
   Dim I As Long
   For I = 0 To 3: mField(ox + hox(I), oy + hoy(I)) = objnr: Next I
End Sub

' take the prepared piece (in preview), make it the current
' prepare a new one
Private Sub TakeNextObj()
   Dim I As Long
   ox = px2 \ 2: oy = 1
   objnr = nxtobjnr
   For I = 1 To 3: hox(I) = nox(I): hoy(I) = noy(I): Next I
   MakeNextObj
End Sub

' draw the whole playing field
Private Sub ShowField()
   Dim X As Integer, Y As Integer
   
   P1.Cls
   For X = px1 To px2 - 1: For Y = py1 To py2 - 1
      DrawSquare P1.hDC, X * 16, Y * 16, mField(X, Y)
   Next Y: Next X
   P1.Refresh
End Sub

' turn a piece (obj)
Private Sub Turn(R As Integer)
   Dim z As Integer, I As Integer
   
   If objnr > 6 Then Exit Sub
   For I = 1 To 3
      If R = 1 Then z = hox(I): hox(I) = hoy(I): hoy(I) = -z
      If R = 2 Then z = hox(I): hox(I) = -hoy(I): hoy(I) = z
   Next I
End Sub
' generate pauze
Private Sub Pauze(ds As Integer)
   Dim sec As Single
   Dim td As Variant
   
   sec = ds / 1000
   td = Timer
   While Timer - td < sec: DoEvents: Wend
End Sub

' draw one single piece-square
Private Sub DrawSquare(ByVal phDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal tpe As Integer)
BitBlt phDC, X - 16, Y - 16, 16, 16, frmStris.picSqrs.hDC, 0, tpe * 16, SRCCOPY
End Sub

' at the start of this program...
Private Sub DrawBackground()
   Dim W As Long, H As Long, Wa As Long, Ha As Long
   Dim X As Long, Y As Long, dX As Long, dY As Long
   Dim I As Long
   Static RndDone As Boolean
   
   'Random background
   If RndDone = False Then
      Randomize
      dX = picBg.ScaleWidth - 1
      dY = picBg.ScaleHeight - 1
      picBg.Cls
      For I = 0 To 750
         X = Int(dX * Rnd + 1)
         Y = Int(dY * Rnd + 1)
         picBg.PSet (X, Y), QBColor(8)
         picBg.PSet (X + 1, Y + 1), QBColor(15)
      Next I
      RndDone = True
      End If
   
   'Tile
   W = 128: H = 128
   Wa = (Me.ScaleWidth \ W) + 1
   Ha = (Me.ScaleHeight \ H) + 1
   For Y = Ha To 0 Step -1
      For X = 0 To Wa
         BitBlt Me.hDC, X * W, Y * H, W, H, picBg.hDC, 0, 0, SRCCOPY
      Next X
   Next Y
   
   'Title
   FontName = "Times New roman": FontSize = 26
   X = 780: Y = 110
   ForeColor = QBColor(0)
   CurrentX = X - 15: CurrentY = Y - 1: Print "Stris"
   ForeColor = QBColor(15)
   CurrentX = X + 15: CurrentY = Y + 1: Print "Stris"
   ForeColor = QBColor(7)
   CurrentX = X: CurrentY = Y: Print "Stris"
End Sub

' check if new full lines are made
Private Sub CheckLines()
Dim fl As Integer, X As Integer, Y As Integer, xX As Integer, yY As Integer
    
    While fl = 0: fl = 1      ' repeat until there are no more full lines found
      For Y = 20 To 2 Step -1 ' from top to bottom
        X = 0
        Do: X = X + 1: Loop Until mField(X, Y) = 0 Or X = px2
        If X = px2 Then       ' no hole = full line
          Lines = Lines + 1
          lblLines(0).Caption = Lines: lblLines(1).Caption = lblLines(0).Caption
          For yY = Y To 1 Step -1: For X = 1 To px2 ' erase line
          mField(X, yY) = mField(X, yY - 1): Next X: Next yY
          For X = 1 To px2 - 1: mField(X, 1) = 0: Next X
          Score = Score + 1000
          lblScore(0).Caption = Score: lblScore(1).Caption = lblScore(0).Caption
          fl = 0
          ShowField
          End If
      Next Y
    Wend
    ' look for remaining balls(=8) in mField
    fl = 0
    For X = 1 To px2 - 1: For Y = 1 To 20
    If mField(X, Y) = 8 Then fl = 1: Exit For
    Next Y: Next X
    If fl = 0 Then ' no more balls
        NextLevel
        Score = Score + Abs(100000 \ (Lines - vLin)) ' the less lines, the more points
        If (Level - StartedAt) Mod 5 = 0 Then Score = Score + 50000 ' 6 levels since start?
        lblScore(0).Caption = Score: lblScore(1).Caption = lblScore(0).Caption
        vLin = Lines
        Pauze 2000
        Exit Sub
        End If

End Sub
' is a piece able to turn, drop further
Private Sub CheckSituation()
   Dim I As Long
   
   Stat = 0
   For I = 0 To 3
   If mField(ox + hox(I), oy + hoy(I)) <> 0 Then Stat = 1: Exit Sub
   Next I
End Sub

' clear playing field
Private Sub ClsField()
Dim X As Integer, I As Integer, Y As Integer
    For X = 0 To px2: For Y = 0 To 21: mField(X, Y) = 0: Next Y: Next X
    For I = 0 To 21: mField(0, I) = 1: mField(px2, I) = 1: Next I
    For I = 0 To px2: mField(I, 21) = 1: mField(I, 0) = 1: Next I
End Sub

' read all level data
Private Sub LoadLevels()
   Dim ch As Long
   Dim X As Long, Y As Long
   Dim I As Long
   Dim T As String, R As String

   ch = FreeFile
   Open App.Path & "\Levels.dat" For Input As ch
   For I = 0 To 99
      Line Input #ch, T
      Line Input #ch, T: SLevel(I).px2 = Val(T)
      Line Input #ch, T: SLevel(I).mTime = Val(T)
      For Y = 0 To 21
        Line Input #ch, SLevel(I).R(Y)
      Next Y
   Next I
   Close ch

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
   If KeyCode = vbKeyS Then cmdStartStop_Click: KeyCode = 0: Exit Sub
   If KeyCode = 18 And Playing = True Then KeyCode = 0: Exit Sub
   If Playing = False Then Exit Sub
   KeyPze = True
   Select Case KeyCode
      Case vbKeyLeft: ox = ox - 1:  CheckSituation: If Stat = 1 Then ox = ox + 1 Else DrawPiece
      Case vbKeyRight: ox = ox + 1:  CheckSituation: If Stat = 1 Then ox = ox - 1 Else DrawPiece
      Case vbKeyUp: Turn 1: CheckSituation: If Stat = 1 Then Turn 2 Else DrawPiece
      Case vbKeyDown: ObjDown
      Case vbKeySpace
         KeyPze = False: tmrPlay.Enabled = False
         While KeyPze = False: ObjDown: Pauze 20: Wend
         If KeyPze = True And Playing = True Then tmrPlay.Enabled = True
   End Select
End Sub

Private Sub Form_Load()
   px1 = 1:  py1 = 1: py2 = 21: px2 = 20
   Gr = 16 * 15
   PieceMode = 7
   LoadLevels
   obj(1, 0) = -1: obj(1, 1) = 0: obj(1, 2) = 1: obj(1, 3) = 0: obj(1, 4) = 2: obj(1, 5) = 0
   obj(2, 0) = -1: obj(2, 1) = 0: obj(2, 2) = 1: obj(2, 3) = 0: obj(2, 4) = 1: obj(2, 5) = -1
   obj(3, 0) = -1: obj(3, 1) = 0: obj(3, 2) = 1: obj(3, 3) = 0: obj(3, 4) = 1: obj(3, 5) = 1
   obj(4, 0) = -1: obj(4, 1) = 0: obj(4, 2) = 1: obj(4, 3) = 0: obj(4, 4) = 0: obj(4, 5) = 1
   obj(5, 0) = -1: obj(5, 1) = 0: obj(5, 2) = 0: obj(5, 3) = 1: obj(5, 4) = 1: obj(5, 5) = 1
   obj(6, 0) = -1: obj(6, 1) = 0: obj(6, 2) = 0: obj(6, 3) = -1: obj(6, 4) = 1: obj(6, 5) = -1
   obj(7, 0) = -1: obj(7, 1) = 0: obj(7, 2) = -1: obj(7, 3) = 1: obj(7, 4) = 0: obj(7, 5) = 1
   obj(8, 0) = 0: obj(8, 1) = 0: obj(8, 2) = 0: obj(8, 3) = 0: obj(8, 4) = 0: obj(8, 5) = 0
   DrawBackground
   MakeReady
End Sub

Private Sub Form_Resize()
   DrawBackground
End Sub

Private Sub imgHelp_Click()
   On Error Resume Next
   AppActivate "strishelp.txt", False
   If Err = 0 Then Exit Sub
   Err = 0
   Shell "notepad.exe " & App.Path & "\strishelp.txt", vbNormalFocus
   If Err <> 0 Then MsgBox Err.Description
   On Error GoTo 0
End Sub

Private Sub chkBalls_Click()
   If chkBalls.Value = 0 Then
      PieceMode = 7
      Else
      PieceMode = 8
      End If
End Sub

Private Sub cmdStartStop_Click()
   Dim txt As String
   
   Select Case cmdStartStop.Caption
   
   Case "&Start"
   
   DialogTitle = "Stris - Start game"
   txt = "After clicking the Start button," & vbCrLf
   txt = txt & "you will hear 3 beeps, followed by" & vbCrLf
   txt = txt & "the first piece starting to fall." & vbCrLf
   txt = txt & "Ready to start?"
   DialogText = txt
   OK = False: frmDial.Show 1
   If OK = False Then Exit Sub
         
   chkBalls.Enabled = False
   Level = StartLevel
   StartedAt = StartLevel
   Score = 0: Lines = 0: vLin = 0
   MakeReady
   Playing = True
   Beep
   Pauze 1000: Beep: Pauze 1000: Beep: Pauze 1000
   P1.SetFocus
   Tmr1.Enabled = True
   KeyPreview = True
   tmrPlay.Interval = mTime
   tmrPlay.Enabled = True
   cmdStartStop.Caption = "&Stop"
   
   Case "&Stop"
   
   KeyPze = True
   tmrPlay.Enabled = False
   Tmr1.Enabled = False
   Playing = False
   
   DialogTitle = "Stris - Pauze"
   txt = "Dear Stris Player" & vbCrLf & vbCrLf
   txt = txt & "You want to rest for a while," & vbCrLf
   txt = txt & "get some coffee, smoke a sigaret (please don't) ... ?" & vbCrLf
   txt = txt & "Or is it not your day, you have enough of it ?!" & vbCrLf
   txt = txt & "If I were you, I would continue!" & vbCrLf
   DialogText = txt
   frmDial.Show 1
   If OK = True Then
      P1.SetFocus
      Playing = True
      tmrPlay.Enabled = True
      Tmr1.Enabled = True
      tmrPlay.Interval = mTime
      Else
      chkBalls.Enabled = True
      Level = 0
      SetLevel
      Playing = False
      KeyPreview = False
      cmdStartStop.Caption = "&Start"
      End If

   End Select
End Sub

' preview
Private Sub P2_Click()
   If Playing = True Then Exit Sub
   MakeNextObj
End Sub

' tempo increase Timer
Private Sub Tmr1_Timer()
   If mTime > 150 Then mTime = mTime - 25
   lblSpeed(0).Caption = Format(mTime, "000")
   lblSpeed(1).Caption = lblSpeed(0).Caption
   tmrPlay.Interval = mTime
End Sub

' drop pieces (obj) Timer
Private Sub TmrPlay_Timer()
   ObjDown
End Sub