2048-初始化
2048是比较流行的一款数字游戏，每次可以选择上下左右其中一个方向去滑动，每滑动一次，所有的数字方块都会往滑动的方向靠拢外，系统也会在空白的地方乱数出现一个数字方块，相同数字的方块在靠拢、相撞时会相加。不断的叠加最终拼凑出2048这个数字就算成功。
根据Gabriele Cirulli大神的源代码和参考网上大神的源码制作了这个VB版的2048。
好像从开始玩到现在从来都没有玩到过2048，（好吧，我的游戏技术不好），但是有了源代码...4096都不是梦，悄悄地改一个变量积分就刷刷的。
基于大量的函数制作，颜色用了VB的填充，因为不会dll动态数据库的使用，所有没有声音，没有精美的背景。
游戏玩法很简单：
上下左右移动键盘即可，点击New Game开始新一轮的游戏。
游戏代码:
Option Explicit
Dim BoxValue(3, 3) As Integer '格子的数量
Dim Score As Long '得分
Dim fWidth As Single
Dim mLeft As Integer, mTop As Integer
Dim mSize As Integer
'按键部分
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
scorel.Caption = "Score：" & Score
KeyPreview = True
Select Case KeyCode
Case vbKeyLeft
Call MoveBox(1)
Case vbKeyRight
Call MoveBox(2)
Case vbKeyUp
Call MoveBox(3)
Case vbKeyDown
Call MoveBox(4)
'Case vbKeySpace
' Call NewGame 按下空格新建游戏
End Select
End Sub
Private Sub Form_Load()
KeyPreview = True
Me.Width = 7000
Me.Height = 8000
Me.Caption = "2048"
Me.KeyPreview = True
Me.AutoRedraw = True
Me.ScaleMode = 3
Me.FontSize = 32
fWidth = TextWidth("0")
mSize = 450
mLeft = (Me.ScaleWidth - mSize) / 2
mTop = (Me.ScaleHeight - mSize - mLeft)
Call NewGame
End Sub
'开始游戏
Private Sub NewGame()
Dim R As Integer, C As Integer
Line (mLeft, mTop)-(mLeft + 450, mTop + 450), RGB(128, 128, 128), BF
Line (mLeft + 1, mTop + 1)-(Me.ScaleWidth - mLeft, Me.ScaleHeight - mLeft - 1), RGB(40, 40, 40), B
For R = 0 To 3
For C = 0 To 3
DrawBox 0, R, C
Next
Next
Score = 0
Call NewBox
Call NewBox
End Sub
'画出格子
Private Sub DrawBox(ByVal N As Integer, ByVal R As Integer, ByVal C As Integer)
Dim L As Integer, T As Integer
Dim tmpStr As String
L = C * 110 + 10 + mLeft
T = R * 110 + 10 + mTop
If N = 0 Then
Line (L + 1, T + 1)-(L + 102, T + 102), RGB(100, 100, 100), BF
Line (L, T)-(L + 100, T + 100), RGB(203, 192, 177), BF
Else
Line (L, T)-(L + 100, T + 100), BoxColor(N), BF
Line (L + 2, T + 2)-(L + 99, T + 99), RGB(100, 100, 100), B
Line (L + 1, T + 1)-(L + 98, T + 98), RGB(216, 216, 216), B
tmpStr = Trim(Str(N))
CurrentX = L + (100 - TextWidth(tmpStr)) / 2 - fWidth
CurrentY = T + (100 - TextHeight(tmpStr)) / 2
Print N
End If
BoxValue(R, C) = N
End Sub
'移动格子
Private Sub MoveBox(ByVal Fx As Integer)
Dim B As Integer, N As Integer, S As Integer
Dim R As Integer, C As Integer, K As Integer
Dim bMove As Boolean
If Fx < 3 Then '左右移动
If Fx = 1 Then
B = 1: N = 3: S = 1
Else
B = 2: N = 0: S = -1
End If
For R = 0 To 3
K = IIf(Fx = 1, 0, 3)
For C = B To N Step S
If BoxValue(R, C) > 0 Then
If (BoxValue(R, C) = BoxValue(R, K)) Then
DrawBox BoxValue(R, C) * 2, R, K
DrawBox 0, R, C
Score = Score + BoxValue(R, K)
If BoxValue(R, K) = 2048 Then
MsgBox "You Win!", vbInformation
End If
bMove = True
Else
If BoxValue(R, K) > 0 Then
K = K + S
If K <> C Then
DrawBox BoxValue(R, C), R, K
DrawBox 0, R, C
bMove = True
End If
Else
DrawBox BoxValue(R, C), R, K
DrawBox 0, R, C
bMove = True
End If
End If
End If
Next C
Next R
Else '上下移动
If Fx = 3 Then
B = 1: N = 3: S = 1
Else
B = 2: N = 0: S = -1
End If
For C = 0 To 3
K = IIf(Fx = 3, 0, 3)
For R = B To N Step S
If BoxValue(R, C) > 0 Then
If BoxValue(R, C) = BoxValue(K, C) Then
DrawBox BoxValue(R, C) * 2, K, C
DrawBox 0, R, C
Score = Score + BoxValue(K, C)
If BoxValue(R, K) = 2048 Then
MsgBox "You Win!", vbInformation
End If
bMove = True
Else
If BoxValue(K, C) > 0 Then
K = K + S
If K <> R Then
DrawBox BoxValue(R, C), K, C
DrawBox 0, R, C
bMove = True
End If
Else
DrawBox BoxValue(R, C), K, C
DrawBox 0, R, C
bMove = True
End If
End If
End If
Next R
Next C
End If
If bMove Then
' Call PrintScore
Call NewBox
' 检查死局
For R = 0 To 3
For C = 0 To 3
If BoxValue(R, C) = 0 Then Exit Sub
If R < 3 Then If BoxValue(R, C) = BoxValue(R + 1, C) Then Exit Sub
If C < 3 Then If BoxValue(R, C) = BoxValue(R, C + 1) Then Exit Sub
Next
Next
MsgBox "Game Over!", vbInformation
Call NewGame
End If
End Sub
'产生新方格
Private Sub NewBox()
Dim R As Integer, C As Integer
Randomize
R = Int(Rnd * 4)
C = Int(Rnd * 4)
Do While BoxValue(R, C) > 0
R = Int(Rnd * 4)
C = Int(Rnd * 4)
Loop
BoxValue(R, C) = 2
DrawBox 2, R, C
End Sub
'方格颜色
Private Function BoxColor(ByVal N As Integer) As Long
Select Case N
Case 2
BoxColor = &H80FFFF
Case 4
BoxColor = &H80C0FF
Case 8
BoxColor = &H8080FF
Case 16
BoxColor = &HFFFF&
Case 32
BoxColor = &H80FF&
Case 64
BoxColor = &H40C0&
Case 128
BoxColor = &HFF00FF
Case 256
BoxColor = &HFF8080
Case 512
BoxColor = &HC000&
Case 1024
BoxColor = &H808000
Case 2048
BoxColor = &HFF&
End Select
End Function
Private Sub newgamel_Click()
Call NewGame
End Sub
点击下载
密码：t54s
@ Mayuko
