好玩的VB

贪吃蛇游戏

Option Explicit

Private WithEvents Timer1 As Timer

Private WithEvents Label1 As Label

Dim GFangXiang As Boolean

Dim HWB As Single

Dim She() As ShenTi

Dim X As Long, Y As Long

Dim ZhuangTai(23, 23) As Long

Private Type ShenTi

F As Long

X As Long

Y As Long

End Type

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Dim C As Long

If KeyCode = 27 Then End

If KeyCode = 32 Then

If Timer1.Enabled = True Then

Timer1.Enabled = False

Label1.Visible = True

Else

Timer1.Enabled = True

Label1.Visible = False

End If

End If

C = UBound(She)

If GFangXiang = True Then Exit Sub

Select Case KeyCode

Case 37

If She(C).F = 2 Then Exit Sub

She(C).F = 0

GFangXiang = True

Case 38

If She(C).F = 3 Then Exit Sub

She(C).F = 1

GFangXiang = True

Case 39

If She(C).F = 0 Then Exit Sub

She(C).F = 2

GFangXiang = True

Case 40

If She(C).F = 1 Then Exit Sub

She(C).F = 3

GFangXiang = True

End Select

End Sub

Private Sub Form_Load()

Me.AutoRedraw = True

Me.BackColor = &HC000&

Me.FillColor = 255

Me.FillStyle = 0

Me.ScaleWidth = 24

Me.ScaleHeight = 24

Me.WindowState = 2

Set Timer1 = Controls.Add("VB.Timer", "Timer1")

Set Label1 = Controls.Add("https://www.360docs.net/doc/8b13413771.html,bel", "Label1")

Label1.AutoSize = True

Label1.BackStyle = 0

Label1 = "暂停"

Label1.ForeColor = RGB(255, 255, 0)

Label1.FontSize = 50

ChuShiHua

End Sub

Private Sub Form_Resize()

On Error GoTo 1:

With Me

If .WindowState <> 1 Then

.Cls

.ScaleMode = 3

HWB = .ScaleHeight / .ScaleWidth

.ScaleWidth = 24

.ScaleHeight = 24

Label1.Move (Me.ScaleWidth - Label1.Width) / 2, (Me.ScaleHeight - Label1.Height) / 2 HuaTu

Me.Line (X, Y)-(X + 1, Y + 1), RGB(255, 255, 0), BF

End If

End With

1:

End Sub

Private Sub Timer1_Timer()

Dim C As Long, I As Long

On Error GoTo 2:

QingChu

C = UBound(She)

Select Case She(C).F

Case 0

If ZhuangTai(She(C).X - 1, She(C).Y) = 2 Then

C = C + 1

ReDim Preserve She(C)

She(C).F = She(C - 1).F

She(C).X = She(C - 1).X - 1

She(C).Y = She(C - 1).Y

ChanShengShiWu

GoTo 1:

ElseIf ZhuangTai(She(C).X - 1, She(C).Y) = 1 Then GoTo 2:

End If

Case 1

If ZhuangTai(She(C).X, She(C).Y - 1) = 2 Then

C = C + 1

ReDim Preserve She(C)

She(C).F = She(C - 1).F

She(C).X = She(C - 1).X

She(C).Y = She(C - 1).Y - 1 ChanShengShiWu

GoTo 1:

ElseIf ZhuangTai(She(C).X, She(C).Y - 1) = 1 Then GoTo 2:

End If

Case 2

If ZhuangTai(She(C).X + 1, She(C).Y) = 2 Then

C = C + 1

ReDim Preserve She(C)

She(C).F = She(C - 1).F

She(C).X = She(C - 1).X + 1

She(C).Y = She(C - 1).Y

ChanShengShiWu

GoTo 1:

ElseIf ZhuangTai(She(C).X + 1, She(C).Y) = 1 Then GoTo 2:

End If

Case 3

If ZhuangTai(She(C).X, She(C).Y + 1) = 2 Then

C = C + 1

ReDim Preserve She(C)

She(C).F = She(C - 1).F

She(C).X = She(C - 1).X

She(C).Y = She(C - 1).Y + 1

ChanShengShiWu

GoTo 1:

ElseIf ZhuangTai(She(C).X, She(C).Y + 1) = 1 Then

GoTo 2:

End If

End Select

ZhuangTai(She(0).X, She(0).Y) = 0

For I = 0 To C

Select Case She(I).F

Case 0

She(I).X = She(I).X - 1

Case 1

She(I).Y = She(I).Y - 1

Case 2

She(I).X = She(I).X + 1

Case 3

She(I).Y = She(I).Y + 1

End Select

Next

TiaoZheng

1:

GFangXiang = False

ZhuangTai(She(C).X, She(C).Y) = 1

HuaTu

Exit Sub

2:

If MsgBox("游戏结束，点“是”重新开始游戏，点“否”", vbYesNo, "贪吃蛇") = vbYes Then ChuShiHua

Else

End

End If

End Sub

Private Sub ChuShiHua()

Me.Cls

Timer1.Enabled = True

Timer1.Interval = 200

Erase ZhuangTai

ReDim She(2)

She(0).F = 2

She(0).X = 9

She(0).Y = 11

ZhuangTai(9, 11) = 1

She(1).F = 2

She(1).X = 10

She(1).Y = 11

ZhuangTai(10, 11) = 1

She(2).F = 2

She(2).X = 11

She(2).Y = 11

ZhuangTai(11, 11) = 1

HuaTu

ChanShengShiWu

End Sub

Private Sub QingChu()

Dim I As Long

For I = 0 To UBound(She)

Me.Line (She(I).X, She(I).Y)-(She(I).X + 1, She(I).Y + 1), Me.BackColor, BF Next

End Sub

Private Sub HuaTu()

Dim I As Long

For I = 0 To UBound(She)

Me.Circle (She(I).X + 0.5, She(I).Y + 0.5), 0.49, RGB(255, 255, 0), , , HWB Next

End Sub

Private Sub TiaoZheng()

Dim I As Long

For I = 0 To UBound(She) - 1

She(I).F = She(I + 1).F

Next

End Sub

Private Sub ChanShengShiWu()

Randomize Timer

1:

X = Int(Rnd * 24)

Y = Int(Rnd * 24)

If ZhuangTai(X, Y) > 0 Then GoTo 1:

ZhuangTai(X, Y) = 2

Me.Line (X, Y)-(X + 1, Y + 1), RGB(255, 255, 0), BF

End Sub

五子棋游戏

Option Explicit

Dim blackturn As Boolean '轮到黑方下子

Dim whiteturn As Boolean '轮到白方下子

Dim table(0 To 15, 0 To 15) As Integer '用此二维数组表示棋盘

Dim inti As Integer '数组元素……

Dim intj As Integer

Dim boolstatus As Boolean '表示棋局状态：进行/结束

Private Sub cmdclose_Click() '关闭窗口

Unload Me

Set frmmain = Nothing

End Sub

Private Sub cmdrestart_Click() '重新开始

'窗口清除

Me.Cls

'数组清零

For inti = 0 To 15

For intj = 0 To 15

table(inti, intj) = 0

Next

Next

'重画棋盘

Form_Load

End Sub

Private Sub Form_Load()

'画棋盘

Form_Paint

blackturn = True '黑方先下

boolstatus = True '开始

Label1.Caption = "黑方先下"

End Sub

'下子

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) Dim intx As Integer '落子横向位置

Dim inty As Integer '落子竖向位置

'确定棋局是否在进行中，否，跳出

If boolstatus = False Then

Label1.Caption = "结束"

Exit Sub

End If

'确定落子的确切位置

'如果鼠标点击位置不在棋盘中，则跳出

If x < 10 Or x > 310 Or y < 10 Or y > 310 Then

Exit Sub

End If

'如果鼠标点击位置在棋盘中，则转化为相应棋盘落子点的坐标If (x - 10) Mod 20 < 10 Then

intx = x - (x - 10) Mod 20

Else

intx = x + 20 - (x - 10) Mod 20

End If

If (y - 10) Mod 20 < 10 Then

inty = y - (y - 10) Mod 20

Else

inty = y + 20 - (y - 10) Mod 20

End If

'把坐标转换成数组中的相应元素

inti = (intx - 10) / 20

intj = (inty - 10) / 20

'如果该数组元素不为零，即表示棋盘中相应点已有棋子，则跳出If table(inti, intj) <> 0 Then

Exit Sub

End If

'画子（圆）

If blackturn = True Then

'黑色

Me.FillColor = RGB(0, 0, 0)

table(inti, intj) = 1 '黑子赋1

Label1.Caption = "白方"

Else

'白色

Me.FillColor = RGB(255, 255, 255)

table(inti, intj) = 2 '白子赋2

Label1.Caption = "黑方"

End If

Me.FillStyle = 0 '不可缺

Me.Circle (intx, inty), 8

'判断是否有五子连线

Call judgeman

'轮流

blackturn = Not blackturn '取反

End Sub

Private Sub judgeman() '判断是否有五子连线

Dim strwho As String '下子方名称

If table(inti, intj) = 1 Then '表示黑方下的子

strwho = "黑方"

Else

strwho = "白方"

End If

'分别判断横竖，对角线是否有五子，此段代码比较复杂，可能那以理解，但其执行效率极高

'非常适合与棋盘格子很多的情况

If samelinenums(1, 0) >= 5 Or samelinenums(0, 1) >= 5 Or samelinenums(1, 1) >= 5 Or samelinenums(-1, 1) >= 5 Then

MsgBox strwho & "胜！"

boolstatus = False '棋局结束

End If

End Sub

Function samelinenums(changei As Integer, changej As Integer) '判断同一直线上的棋子数

Dim i As Integer

Dim j As Integer

Dim num As Integer '同一线上相同颜色棋子数

'计算落子一边同颜色的棋子数

i = inti: j = intj

Do

If table(i, j) <> table(inti, intj) Then

num = max(Abs(inti - i), Abs(intj - j))

Exit Do

End If

i = i + changei: j = j + changej

Loop Until i < 0 Or i > 15 Or j < 0 Or j > 15

'计算落子另一边同颜色的棋子数

i = inti: j = intj

Do

If table(i, j) <> table(inti, intj) Then

num = num - 1 + max(Abs(inti - i), Abs(intj - j))

Exit Do

End If

i = i - changei: j = j - changej

Loop Until i < 0 Or i > 15 Or j < 0 Or j > 15

'MsgBox num

samelinenums = num

End Function

'求较大值

Function max(inta As Integer, intb As Integer)

max = inta

If max < intb Then max = intb

End Function

Private Sub Form_Paint() '以(10,10)为左上角坐标画一个16*16,每格边长为20象素的棋盘Cls '清除

Dim i As Integer

ScaleMode = 3 '设定窗体画布的单位为象素

For i = 10 To 330 Step 20

Me.Line (10, i)-(330, i)

Me.Line (i, 10)-(i, 330)

Next

End Sub