fball.frm

一个用VB编的小游戏

Case 0
  i = 8
  For j = 1 To 6
    If Not SpecialPos(i, j) Then X = BitBlt(hd, 320 + m * k, j * 40 - 40, 40, 40, hs, Int(plyGround(i, j) / 2) * 40, (plyGround(i, j) Mod 2) * 40, SRCCOPY)
  Next
Case 1
  i = 0
  For j = 1 To 6
    If Not SpecialPos(i, j) Then X = BitBlt(hd, m * k - 40, j * 40 - 40, 40, 40, hs, Int(plyGround(i, j) / 2) * 40, (plyGround(i, j) Mod 2) * 40, SRCCOPY)
  Next
Case 2
  j = 6
  For i = 1 To 8
    If Not SpecialPos(i, j) Then X = BitBlt(hd, i * 40 - 40, 240 + n * k, 40, 40, hs, Int(plyGround(i, j) / 2) * 40, (plyGround(i, j) Mod 2) * 40, SRCCOPY)
  Next
Case 3
  j = 6
  For i = 1 To 8
    If Not SpecialPos(i, j) Then X = BitBlt(hd, i * 40 - 40, n * k - 40, 40, 40, hs, Int(plyGround(i, j) / 2) * 40, (plyGround(i, j) Mod 2) * 40, SRCCOPY)
  Next
Case Else
End Select
X = BitBlt(hd, Pos(2, 1) * 40 - 40, Pos(2, 2) * 40 - 40, 40, 40, hs, Int(plyGround(Pos(2, 1), Pos(2, 2)) / 2) * 40 + 80, (plyGround(Pos(2, 1), Pos(2, 2)) Mod 2) * 40 + 80, SRCCOPY)
X = BitBlt(hd, Pos(1, 1) * 40 - 40, Pos(1, 2) * 40 - 40, 40, 40, hs, Int(plyGround(Pos(1, 1), Pos(1, 2)) / 2) * 40, (plyGround(Pos(1, 1), Pos(1, 2)) Mod 2) * 40 + 80, SRCCOPY)
X = BitBlt(hd, Pos(0, 1) * 40 - 40 + m * k, Pos(0, 2) * 40 - 40 + n * k, 40, 40, hs, Int(plyGround(Pos(0, 1), Pos(0, 2)) / 2) * 40 + 80, (plyGround(Pos(0, 1), Pos(0, 2)) Mod 2) * 40, SRCCOPY)
k = k + 4
Loop Until k > 40
End If
'PlayGround.Refresh
X = BitBlt(hd, Pos(2, 1) * 40 - 40, Pos(2, 2) * 40 - 40, 40, 40, hs, Int(plyGround(Pos(2, 1), Pos(2, 2)) / 2) * 40 + 80, (plyGround(Pos(2, 1), Pos(2, 2)) Mod 2) * 40 + 80, SRCCOPY)
X = BitBlt(hd, Pos(1, 1) * 40 - 40, Pos(1, 2) * 40 - 40, 40, 40, hs, Int(plyGround(Pos(1, 1), Pos(1, 2)) / 2) * 40, (plyGround(Pos(1, 1), Pos(1, 2)) Mod 2) * 40 + 80, SRCCOPY)
X = BitBlt(hd, Pos(0, 1) * 40 - 40, Pos(0, 2) * 40 - 40, 40, 40, hs, Int(plyGround(Pos(0, 1), Pos(0, 2)) / 2) * 40 + 80, (plyGround(Pos(0, 1), Pos(0, 2)) Mod 2) * 40, SRCCOPY)

End Sub

Private Sub Form_Unload(Cancel As Integer)
tmr.Enabled = False
fResult.Show
End Sub

Private Sub lblFun_Click()
Call NewLevel
End Sub

Private Sub PlayGround_KeyUp(KeyCode As Integer, Shift As Integer)
Dim k, X, Y As Integer
X = Pos(1, 1)
Y = Pos(1, 2)
Select Case KeyCode
Case vbKeyLeft
  k = 0
Case vbKeyRight
  k = 1
Case vbKeyUp
  k = 2
Case vbKeyDown
  k = 3
Case Else
  k = 4
End Select
If k < 4 Then
  Call FixPos(k, X, Y, True)
  Pos(1, 1) = X
  Pos(1, 2) = Y
  lvMoves = lvMoves - 1
  gameMark = gameMark + (30 - Abs(Pos(0, 1) - Pos(1, 1)) - Abs(Pos(0, 2) - Pos(1, 2))) * gameLevel * 10
  lblNO(1).Caption = gameMark
  Call FunTalk
  Call GroundMove(plyGround(Pos(1, 1), Pos(1, 2)))
  Call Caught
End If
End Sub
Private Sub tmr_Timer()
lvTimer = lvTimer - 1
Call GroundDraw(False, 4)
CDT = CDT + 1
If CDT >= 5 - gameLevel / 5 Then
  CDT = CDT - 5 + gameLevel / 5
  mov = Int(Rnd * 4 + 1)
  Select Case mov
  Case 1
  If Pos(2, 1) > 1 Then Pos(2, 1) = Pos(2, 1) - 1
  Case 2
  If Pos(2, 1) < 8 Then Pos(2, 1) = Pos(2, 1) + 1
  Case 3
  If Pos(2, 2) > 1 Then Pos(2, 2) = Pos(2, 2) - 1
  Case 4
  If Pos(2, 2) < 6 Then Pos(2, 2) = Pos(2, 2) + 1
  End Select
  Call Caught
End If
shpTime.Height = Int(244 * lvTimer / (200 - gameLevel * 5))
shpHP.Height = Int(244 * lvMoves / (30 - gameLevel))
shpTime.Top = 252 - shpTime.Height
shpHP.Top = 252 - shpHP.Height
End Sub
Public Sub DoSummary()
tmr.Enabled = False
GetMark = gameMark
CourseMark = gameLevel * 2 + Int(GetMark / 10000)
CourseLevel = gameLevel
tmr.Enabled = False
MsgBox "您辛苦了！", vbOKOnly, "：Ｐ"
Unload Me
End Sub
Public Sub GroundMove(ByVal way As Integer)
Call GroundDraw(True, way)
Select Case way + 1
Case 1 'left red
  For j = 1 To 6
    For i = 0 To 7
      plyGround(i, j) = plyGround(i + 1, j)
    Next
    plyGround(8, j) = plyGround(0, j)
  Next
  Pos(0, 1) = Pos(0, 1) - 1
  If Pos(0, 1) = 0 Then Pos(0, 1) = 8
Case 2 'right blue
  For j = 1 To 6
    plyGround(0, j) = plyGround(8, j)
    For i = 8 To 1 Step -1
      plyGround(i, j) = plyGround(i - 1, j)
    Next
  Next
  Pos(0, 1) = Pos(0, 1) + 1
  If Pos(0, 1) = 9 Then Pos(0, 1) = 1
Case 3 'up yellow
  For i = 1 To 8
    For j = 0 To 5
      plyGround(i, j) = plyGround(i, j + 1)
    Next
    plyGround(i, 6) = plyGround(i, 0)
  Next
  Pos(0, 2) = Pos(0, 2) - 1
  If Pos(0, 2) = 0 Then Pos(0, 2) = 6
Case 4 'down green
  For i = 1 To 8
    plyGround(i, 0) = plyGround(i, 6)
    For j = 6 To 1 Step -1
      plyGround(i, j) = plyGround(i, j - 1)
    Next
  Next
  Pos(0, 2) = Pos(0, 2) + 1
  If Pos(0, 2) = 7 Then Pos(0, 2) = 1
End Select
Call GroundDraw(False, way)
Call Caught
End Sub
Public Sub Caught()
If tmr.Enabled = False Then Exit Sub
If Pos(0, 1) = Pos(2, 1) And Pos(0, 2) = Pos(2, 2) Then
  s = sndPlaySound(App.Path & "\snd\sc" & Int(Rnd * 3 + 1) & ".wav", 1)
  MsgBox "“居然让这些调皮的家伙先拿到球玩起来了！”" & RL & "局面再也无法控制，您被迫引咎“下课”。", vbOKOnly, "失败！"
  Call DoSummary
  Exit Sub
End If
If lvTimer < 0 Then
  s = sndPlaySound(App.Path & "\snd\sc" & Int(Rnd * 3 + 1) & ".wav", 1)
  MsgBox "“已经下课了！”" & RL & "局面再也无法控制，您被迫引咎“下课”。", vbOKOnly, "失败！"
  Call DoSummary
  Exit Sub
End If
If lvMoves < 0 Then
  s = sndPlaySound(App.Path & "\snd\sc" & Int(Rnd * 3 + 1) & ".wav", 1)
  MsgBox "“我已经精疲力尽了！”" & RL & "局面再也无法控制，您被迫引咎“下课”。", vbOKOnly, "失败！"
  Call DoSummary
  Exit Sub
End If
If Pos(0, 1) = Pos(1, 1) And Pos(0, 2) = Pos(1, 2) Then Call NewLevel
End Sub
Public Sub CreateMap()
For i = 1 To 48
  For j = 0 To 3
    BackMove(i, j) = -1
  Next
Next
Randomize
Dim k As Integer
For i = 1 To 8
  For j = 1 To 6
    plyGround(i, j) = -1
    'If i / 2 + j / 2 <> Int(i / 2 + j / 2) Then plyGround(i, j) = Int(Rnd * 4)
  Next
Next
cx = 5
cy = 4
k = Int(Rnd * 4)
BackMove(1, 1) = k  '记录选取方向方案一
BackMove(1, 0) = 1  '记录选取的方案代号
Call FixPos(k, cx, cy, True)
plyGround(cx, cy) = k
Call NextCell(2, k)
For i = 1 To 8
  For j = 1 To 6
    If plyGround(i, j) = -1 Then plyGround(i, j) = Int(Rnd * 4)
    If i / 2 + j / 2 <> Int(i / 2 + j / 2) Then plyGround(i, j) = Int(Rnd * 4)
  Next
Next
l = ""
For i = 47 To 1 Step -2
  If BackMove(i, 1) > -1 Then
    l = l & OppDir(BackMove(i, BackMove(i, 0)))
  End If
Next
'Me.Caption = l
End Sub
Public Sub NextCell(ByVal StepNo, LastMove As Integer)
If (((cx = 1) And (cy = 6))) Or StepNo > 49 Then Exit Sub
Dim k, s As Integer
Dim ok As Boolean
Randomize
BackMove(StepNo, 0) = OppDir(LastMove)
For i = 1 To 3
Do
  k = Int(Rnd * 4)
  ok = True
  For j = 0 To i - 1
    If k = BackMove(StepNo, j) Then ok = False
  Next
Loop Until ok
  BackMove(StepNo, i) = k
Next
If BackTrace(StepNo) = 4 Then
  '需要回溯
  s = StepNo
  Call DoBackUp(s)
  Call NextCell(s, BackMove(StepNo, BackMove(StepNo, 0)))
Else
  '不需要回溯，继续
  BackMove(StepNo, 0) = BackTrace(StepNo)
  Call FixPos(BackMove(StepNo, BackMove(StepNo, 0)), cx, cy, True)
  plyGround(cx, cy) = BackMove(StepNo, BackMove(StepNo, 0))
  Call NextCell(StepNo + 1, BackMove(StepNo, BackMove(StepNo, 0)))
End If
End Sub
Public Sub FixPos(way, X, Y As Integer, ByVal IsForward As Boolean)
If IsForward Then t = 1 Else t = -1
Select Case way
Case 0
  X = X - t
Case 1
  X = X + t
Case 2
  Y = Y - t
Case 3
  Y = Y + t
End Select
If X = 0 Then X = 8
If X = 9 Then X = 1
If Y = 0 Then Y = 6
If Y = 7 Then Y = 1
End Sub
Public Function OppDir(ByVal CDr As Integer) As Integer
Select Case CDr
Case 0, 1
  OppDir = 1 - CDr
Case 2, 3
  OppDir = 5 - CDr
End Select
End Function
Public Function BackTrace(ByVal StepNo As Integer) As Integer
Dim ok As Boolean
ok = False
i = 1
Do
  Call FixPos(BackMove(StepNo, i), cx, cy, True)
  If plyGround(cx, cy) = -1 Then ok = True
  Call FixPos(BackMove(StepNo, i), cx, cy, False)
  i = i + 1
Loop Until (i = 4) Or ok
If ok Then BackTrace = i - 1 Else BackTrace = 4
End Function
Public Sub DoBackUp(StepNo As Integer)
'plyGround(cx, cy) = -1
Call FixPos(BackMove(StepNo, BackMove(StepNo, 0)), cx, cy, False)
BackMove(StepNo, 0) = BackMove(StepNo, 0) + 1
Do While BackMove(StepNo, 0) = 4
  For i = 0 To 3
    BackMove(StepNo, i) = 0
  Next
  StepNo = StepNo - 1
  BackMove(StepNo, 0) = BackMove(StepNo, 0) + 1
Loop
End Sub
Public Function SpecialPos(ByVal i As Integer, ByVal j As Integer) As Boolean
SpecialPos = False
If (Pos(0, 1) = i) And (Pos(0, 2) = j) Then SpecialPos = True
If (Pos(1, 1) = i) And (Pos(1, 2) = j) Then SpecialPos = True
If (Pos(2, 1) = i) And (Pos(2, 2) = j) Then SpecialPos = True
End Function
Public Sub FunTalk()
Randomize
With lblFun
Select Case Int(Rnd * 6 + 1)
Case 1
  .Caption = "走走走走走啊走……"
Case 2
  .Caption = "统统没收！"
Case 3
  .Caption = "向前进，向前进……"
Case 4
  .Caption = "不能被对方拿到！"
Case 5
  .Caption = "走一步，再走一步。"
Case 6
  .Caption = "一失足成千古恨……"
End Select
End With
End Sub