2023年12月26日发(作者：)

启动VB6，在窗体上放一个 picturebox 和一个 label 控件，不用设置属性，复制下面代码到窗口代码区即可：

===============================================

Option Explicit

Dim BoxValue(3, 3) As Integer '格子的数值

Dim Score As Long '得分

'按键

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

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()

= 8000

= 9000

n = "2048"

(idth - 6810) / 2, 1200, 6810, 6810

ance = 0

lor = RGB(128, 128, 128)

ze = 32

draw = True

FontSize = ze

ze = True

,

ze = 24

Style = 0

Label1 = "得分：0"

Call NewGame

End Sub

'开始游戏

Private Sub NewGame()

Dim R As Integer, C As Integer

Dim L As Integer, T As Integer

For R = 1 To 4

For C = 1 To 4

L = (C - 1) * 110 + 10

T = (R - 1) * 110 + 10

(L, T)-(L + 100, T + 100), RGB(200, 200, 200), BF

BoxValue(R - 1, C - 1) = 0

Next

Next

NewBox

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

Dim W As Integer

L = C * 110 + 10

T = R * 110 + 10

If N = 0 Then

(L, T)-(L + 100, T + 100), RGB(200, 200, 200), BF

Else

(L, T)-(L + 100, T + 100), BoxColor(N), BF

tmpStr = Trim(Str(N))

W = TextWidth("0") / erPixelX

tX = L + (100 - TextWidth(tmpStr) / erPixelX) / 2 - W

tY = T + (100 - TextHeight(tmpStr) / erPixelY) / 2

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 "哇塞！太厉害了！佩服佩服~", 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 "哇塞！太厉害了！佩服佩服~", 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

Label1 = "得分：" & Score

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 "无路可走了~~~下次好运！", 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 = &HC0E0FF

Case 4

BoxColor = &H80C0FF

Case 8

BoxColor = &H80FFFF

Case 16

BoxColor = &HC0FFC0

Case 32

BoxColor = &HFFFF80

Case 64

BoxColor = &HFFC0C0

Case 128

BoxColor = &HFF8080

Case 256

BoxColor = &HFFC0FF

Case 512

BoxColor = &HFF80FF

Case 1024

BoxColor = &HC0C0FF

Case 2048

BoxColor = &H8080FF

End Select

End Function