pong.frm

vb课程设计：对对碰游戏 非常不错的游戏

VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H00000000&
   Caption         =   "对对碰1.0                                                  远征工作室"
   ClientHeight    =   7035
   ClientLeft      =   780
   ClientTop       =   1200
   ClientWidth     =   7380
   ForeColor       =   &H0011E8FD&
   Icon            =   "pong.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   Picture         =   "pong.frx":0902
   ScaleHeight     =   469
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   492
   Begin VB.Label lblMsg 
      Appearance      =   0  'Flat
      AutoSize        =   -1  'True
      BackColor       =   &H00162332&
      BackStyle       =   0  'Transparent
      ForeColor       =   &H001DD9E2&
      Height          =   180
      Left            =   600
      TabIndex        =   5
      Top             =   2040
      Width           =   90
   End
   Begin VB.Image Image3 
      Height          =   510
      Left            =   3180
      Picture         =   "pong.frx":D7D7
      Top             =   6495
      Width           =   990
   End
   Begin VB.Label lblScore 
      BackStyle       =   0  'Transparent
      ForeColor       =   &H0011E8FD&
      Height          =   165
      Left            =   3270
      TabIndex        =   4
      Top             =   6750
      Width           =   810
   End
   Begin VB.Label lblLink 
      BackStyle       =   0  'Transparent
      ForeColor       =   &H0011E8FD&
      Height          =   165
      Left            =   3270
      TabIndex        =   3
      Top             =   6570
      Width           =   810
   End
   Begin VB.Label lblNextScore 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      ForeColor       =   &H0011E8FD&
      Height          =   255
      Left            =   4890
      TabIndex        =   2
      Top             =   915
      Width           =   1605
   End
   Begin VB.Label lblNowScore 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      ForeColor       =   &H0011E8FD&
      Height          =   255
      Left            =   915
      TabIndex        =   1
      Top             =   915
      Width           =   1590
   End
   Begin VB.Label lblLevel 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      ForeColor       =   &H0011E8FD&
      Height          =   495
      Left            =   3300
      TabIndex        =   0
      Top             =   495
      Width           =   735
   End
   Begin VB.Image Image2 
      Height          =   480
      Index           =   0
      Left            =   60
      Picture         =   "pong.frx":E1EF
      Top             =   1380
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   9
      Left            =   9120
      Picture         =   "pong.frx":E86B
      Top             =   6000
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   8
      Left            =   9120
      Picture         =   "pong.frx":EF08
      Top             =   5400
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   7
      Left            =   9120
      Picture         =   "pong.frx":F5B3
      Top             =   4800
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   6
      Left            =   9120
      Picture         =   "pong.frx":FC2F
      Top             =   4200
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   5
      Left            =   9120
      Picture         =   "pong.frx":102C9
      Top             =   3600
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   4
      Left            =   9120
      Picture         =   "pong.frx":1093D
      Top             =   3000
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   3
      Left            =   9120
      Picture         =   "pong.frx":10FE2
      Top             =   2400
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   2
      Left            =   9120
      Picture         =   "pong.frx":11695
      Top             =   1800
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   1
      Left            =   9120
      Picture         =   "pong.frx":11D19
      Top             =   1200
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   0
      Left            =   9120
      Picture         =   "pong.frx":123BB
      Top             =   600
      Width           =   480
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Level As Long
Dim Score As Long
Dim picNothing As Image
Dim pic(149) As Long
Dim sel(149) As Boolean
Dim selected As Boolean
Dim NowLink() As Long
Dim High(14) As Long
Dim Row As Long
Dim CountLink As Long

'开始游戏
Private Sub Image3_Click()
AutoRedraw = 0
Image3.Visible = False
init
End Sub

'规划窗体,物件数组从上往下,从左往右布置
Private Sub Form_Load()
Dim i As Long
'Show
'Image2(0).Visible = True
For i = 1 To 149
Load Image2(i)
Image2(i).Left = 4 + (i \ 10) * 32
Image2(i).Top = 92 + (i Mod 10) * 32
Next
showhelp
End Sub

'显示帮助
Sub showhelp()
   ' 创建信息。
   lblMsg = "                          【游戏简单说明】" & vbNewLine & vbNewLine _
     & vbNewLine & vbNewLine & "●鼠标点击任一物件,自动选中相连的同种物件.再次点击选中的物件,便可消除." _
     & vbNewLine & vbNewLine & "●聚集更多的物件一次性消除后可以得到更多的分数." _
     & vbNewLine & vbNewLine & "●消除时上部的物件会往下填补空缺." _
     & vbNewLine & vbNewLine & "●当某列全部为空时,右侧的物件会整体往左移动一列填补." _
     & vbNewLine & vbNewLine & "●当物件不再有相连时,会根据剩余个数考虑是否加分.剩余越少,加分越多." _
     & vbNewLine & vbNewLine & "●目前分数不少于过关分数时,会进入下一级别继续游戏,否则游戏结束重新开始."
End Sub

'初始化随机排列物件
Sub init()
Level = 0
Score = 0
lblNowScore = Score
NewLever
End Sub

'进入新关
Sub NewLever()
Dim i As Long
lblMsg.Visible = False
Level = Level + 1
Randomize
For i = 0 To 149
   pic(i) = Int(Rnd * 5)
   Image2(i) = Image1(pic(i))
   Image2(i).Visible = True
Next
Row = 14
For i = 0 To 14
High(i) = 9
Next
CountLink = 0
lblLevel = "级别" & vbCrLf & Level
lblNowScore = "目前得分:" & Format(Score, "@@@@@@")
lblNextScore = "过关分数:" & Format(Level * (Level + 4) * 500, "@@@@@@")
selected = False
End Sub

'选取物件并作相应处理
Private Sub Image2_Click(Index As Integer)
If pic(Index) = -1 Then Exit Sub
If selected Then
   If sel(Index) Then dele Else Reset Index
Else
   ReDim NowLink(0)
   CountLink = 0
   linked Index
   selected = True
End If
End Sub

'消除物件
Sub dele()
Dim i As Long
Dim j As Long
Dim k As Long
If CountLink = 1 Then Exit Sub
For i = 0 To UBound(NowLink)
   sel(NowLink(i)) = False
   pic(NowLink(i)) = -1
Next
For i = 0 To Row
   For j = 9 - High(i) To 9
      If pic(i * 10 + j) = -1 Then
         For k = j To 10 - High(i) Step -1
            pic(i * 10 + k) = pic(i * 10 + k - 1)
         Next
         pic(i * 10 + 9 - High(i)) = -1
         High(i) = High(i) - 1
      End If
   Next
Next
For i = Row To 0 Step -1
   If High(i) = -1 Then
      For j = i To Row - 1
         For k = 0 To 9
            pic(j * 10 + k) = pic(j * 10 + k + 10)
         Next
         High(j) = High(j + 1)
      Next
      For j = Row * 10 To Row * 10 + 9
         pic(j) = -1
      Next
      Row = Row - 1
   End If
Next
For i = 0 To 149
If pic(i) = -1 Then
   Image2(i) = picNothing
Else
   Image2(i) = Image1(pic(i))
End If
Next
Score = Score + CountLink * (CountLink + 2) * 5
lblNowScore = "目前得分:" & Format(Score, "@@@@@@")
selected = False
lblLink = "连接:"
lblScore = "分数:"
isLink
End Sub

'重新选取物件
Sub Reset(Index As Integer)
Dim i As Long
For i = 0 To UBound(NowLink)
   sel(NowLink(i)) = False
   Image2(NowLink(i)) = Image1(pic(NowLink(i)))
Next
ReDim NowLink(0)
CountLink = 0
linked Index
End Sub

'标记相连的物件
Sub linked(Index As Integer)
CountLink = CountLink + 1
sel(Index) = True
NowLink(UBound(NowLink)) = Index
Image2(Index) = Image1(pic(Index) + 5)
If Index \ 10 > 0 Then
   If pic(Index - 10) = pic(Index) And Not sel(Index - 10) Then
      ReDim Preserve NowLink(UBound(NowLink) + 1)
      linked Index - 10
   End If
End If
If Index \ 10 < 14 Then
   If pic(Index + 10) = pic(Index) And Not sel(Index + 10) Then
      ReDim Preserve NowLink(UBound(NowLink) + 1)
      linked Index + 10
   End If
End If
If Index Mod 10 > 0 Then
   If pic(Index - 1) = pic(Index) And Not sel(Index - 1) Then
      ReDim Preserve NowLink(UBound(NowLink) + 1)
      linked Index - 1
   End If
End If
If Index Mod 10 < 9 Then
   If pic(Index + 1) = pic(Index) And Not sel(Index + 1) Then
      ReDim Preserve NowLink(UBound(NowLink) + 1)
      linked Index + 1
   End If
End If
lblLink = "连接:" & Format(CountLink, "@@@@")
lblScore = "分数:" & Format(CountLink * (CountLink + 2) * 5 - IIf(CountLink > 1, 0, 15), "@@@@")
End Sub
 
'是否还有连接物件
Sub isLink()
Dim i As Long
Dim j As Long
Dim bonus As Long
Dim ys As Single
For i = 0 To Row
   For j = 9 - High(i) To 8
      If pic(i * 10 + j) = pic(i * 10 + j + 1) Then Exit Sub
   Next
Next
For i = 1 To Row Step 2
   For j = 9 - High(i) To 9
      If pic(i * 10 + j) = pic(i * 10 + j - 10) Then Exit Sub
      If pic(i * 10 + j) = pic(i * 10 + j + 10) Then Exit Sub
   Next
Next
j = 0
For i = 0 To Row
j = j + High(i) + 1
Next
bonus = IIf(j < 25, (25 - j) * (25 - j) * 25, 0)
lblMsg = "剩余个数:" & Format(j, "@@@") & "个" & "    加分:" & Format(bonus, "@@@@@") & "分"
lblMsg.FontSize = 16   ' 设置字体大小。
lblMsg.Left = (ScaleWidth - lblMsg.Width) / 2
lblMsg.BackStyle = 1
lblMsg.Visible = True
Score = Score + bonus
lblNowScore = "目前得分:" & Score
ys = Timer
Do While Timer - ys < 2
DoEvents
Loop
If Score < Level * (Level + 4) * 500 Then
   lblMsg = "游戏失败,再来吧!"
   lblMsg.Left = (ScaleWidth - lblMsg.Width) / 2
   ys = Timer
   Do While Timer - ys < 2
   DoEvents
   Loop
   init
Else
   lblMsg = "恭喜进入下一关!"
   lblMsg.Left = (ScaleWidth - lblMsg.Width) / 2
   ys = Timer
   Do While Timer - ys < 2
   DoEvents
   Loop
   NewLever
End If
End Sub