1.我想要一个用vb编的黑白五子棋的源码(不要超连接的)
我想要一个用vb编的五子棋的源码(不要超连接的)
'在窗体上加入以下控件
'image1(0),image1(0) - 黑白棋
'image2,image3(0)
'form中的picture为棋盘。因无法上传，棋源问答源码php请自行领会。码黑码nmon源码
Option Explicit
Dim I,白棋Mfoc源码 J, K, Counter, Firstmoved, Rt, Gen, r, flag As Integer
Dim Grid(), H(), V(), RL(), LR(), Tb(2), Order() As Integer
Private Sub Form_Initialize()
lblHelp.Top = 0
lblHelp.Left = 0
Image1(0).Top = -
Image1(1).Top = -
lblHelp.Left = -lblHelp.Width
lblHelp = vbCrLf + vbCrLf + " 游戏帮助" + vbCrLf _
+ vbCrLf + vbCrLf + "●游戏规则:黑方先行,轮流弈子,任一方向先连成五子者胜." _
+ vbCrLf + vbCrLf + vbCrLf + "●操作提示:①可选择[先后]、[难度]和[对手]菜单设置游戏,源代mpq 源码" _
+ vbCrLf + vbCrLf + " 只有按[游戏]->[开始]后才可在棋盘上落子." _
+ vbCrLf + vbCrLf + " ②按[游戏]->[清盘]可重玩并设置游戏." _
+ vbCrLf + vbCrLf + " ③落子后按[动作]菜单下的选择可任意悔棋和恢复." _
+ vbCrLf + vbCrLf + " ④各功能菜单都提供了快捷键(Alt+相应字母)." _
+ vbCrLf + vbCrLf + vbCrLf + "●有什么问题请与本人联系.电子邮件:xwwxyz@sina.com." _
+ vbCrLf + vbCrLf + vbCrLf + "●本页面单击后隐藏."
End Sub
Private Sub Form_Resize()
Me.Height =
Me.Width =
End Sub
Private Sub lblHelp_Click()
lblHelp.Visible = False
End Sub
Private Sub mnuAfter_Click()
Firstmoved = 0
mnuAfter.Checked = True
mnuFirst.Checked = False
End Sub
Private Sub Form_Load()
Dim I As Integer
For I = 1 To
Load Image3(I) '加载棋子控件
Image3(I).Top = (I \ ) * + 5
Image3(I).Left = (I Mod ) * + 5
Image3(I).Visible = True
Next
Ini
End Sub
'游戏初始化
Sub Ini()
For I = 0 To
Image3(I) = Image2
Image3(I).Enabled = False
Grid(I) = 0
V(I) = 0
H(I) = 0
LR(I) = 0
RL(I) = 0
Next I
mnuBack.Enabled = False
Counter = 0
Gen = 0
If mnuAfter.Checked = True Then
Firstmoved = 0
Else
Firstmoved = 1
End If
mnuStart.Enabled = True
End Sub
'一方是否可获胜
Function LineWin(Piece As Integer) As Integer
Dim mun As Integer
LineWin =
'五子一线
mun = Piece * 5
For I = 0 To
If H(I) = mun Or V(I) = mun Or RL(I) = mun Or LR(I) = mun Then
LineWin = + Piece
Exit Function
End If
Next I
'四子一线
mun = Piece * 4
For I = 0 To
If H(I) = mun Then
For K = 0 To 4
If Grid(I + K) = 0 Then LineWin = I + K: Exit Function
Next K
End If
If V(I) = mun Then
For K = 0 To 4
If Grid(I + K * ) = 0 Then LineWin = I + K * : Exit Function
Next K
End If
If RL(I) = mun Then
For K = 0 To 4
If Grid(I + K * ) = 0 Then LineWin = I + K * : Exit Function
Next K
End If
If LR(I) = mun Then
For K = 0 To 4
If Grid(I + K * ) = 0 Then LineWin = I + K * : Exit Function
Next K
End If
Next I
End Function
'计算机走棋
Sub ComputerMove()
Dim ToMove As Integer
If Counter = 0 Then
Randomize
I = Int(Rnd * 7 + 4)
J = Int(Rnd * 7 + 4)
If Grid(I * + J) = 0 Then ToMove = I * + J
Else
If mnuLower.Checked = True Then ToMove = Defend Else ToMove = Attempt
End If
Counter = Counter + 1
If Firstmoved = 0 Then Image3(ToMove) = Image1(0) Else Image3(ToMove) = Image1(1)
Grid(ToMove) = 2
Order(Counter) = ToMove
LineGen ToMove, 6
If LineWin(6) = Then
MsgBox "您输了!"
Ini
Exit Sub
End If
If Counter = Then
MsgBox "和棋"
Ini
Exit Sub
End If
End Sub
'低级模式
Function Defend() As Integer
Rt = LineWin(6)
If Rt < Then Defend = Rt: Exit Function
Rt = LineWin(1)
If Rt < Then Defend = Rt: Exit Function
'查找落子位置
Rt = FindBlank
If Rt < Then Defend = Rt: Exit Function
End Function
'悔棋
Private Sub mnuBack_Click()
mnuComeback.Enabled = True
If (Counter + Firstmoved) Mod 2 = 0 Then Rt = -1 Else Rt = -6
Grid(Order(Counter)) = 0
Image3(Order(Counter)) = Image2
LineGen Order(Counter), Rt
Counter = Counter - 1
If mnuComputer.Checked = True Then
Grid(Order(Counter)) = 0
Image3(Order(Counter)) = Image2
LineGen Order(Counter), -1
Counter = Counter - 1
Else
flag = 1 - flag
End If
r = r + 1
If Counter = 1 And Firstmoved = 0 And mnuComputer.Checked = True Then mnuBack.Enabled = False
If Counter = 0 Then mnuBack.Enabled = False
End Sub
'恢复棋子
Private Sub mnuComeback_Click()
mnuBack.Enabled = True
Counter = Counter + 1
If (Counter + Firstmoved) Mod 2 = 0 Then
Grid(Order(Counter)) = 1
Image3(Order(Counter)) = Image1(1 - Firstmoved)
LineGen Order(Counter), 1
Else
Grid(Order(Counter)) = 2
Image3(Order(Counter)) = Image1(Firstmoved)
LineGen Order(Counter), 6
End If
If mnuComputer.Checked = True Then
Counter = Counter + 1
Grid(Order(Counter)) = 2
Image3(Order(Counter)) = Image1(Firstmoved)
LineGen Order(Counter), 6
Else
flag = 1 - flag
End If
r = r - 1
If r = 0 Then mnuComeback.Enabled = False
End Sub
Private Sub mnuComputer_Click() '对手
mnuComputer.Checked = True '电脑
mnuHuman.Checked = False '棋手
End Sub
Private Sub mnuClear_Click() '清盘
Ini
mnuFirst.Enabled = True
mnuAfter.Enabled = True
mnuLower.Enabled = True
mnuHigher.Enabled = True
mnuComputer.Enabled = True
mnuHuman.Enabled = True
End Sub
Private Sub mnuHuman_Click()
mnuHuman.Checked = True
mnuComputer.Checked = False
End Sub
Private Sub mnuStart_Click() '开始
lblHelp.Visible = False
For I = 0 To
Image3(I).Enabled = True
Next I
mnuFirst.Enabled = False
mnuAfter.Enabled = False
mnuLower.Enabled = False
mnuHigher.Enabled = False
mnuComputer.Enabled = False
mnuHuman.Enabled = False
If Firstmoved = 0 And mnuComputer.Checked = True Then ComputerMove
If Firstmoved = 0 And mnuHuman.Checked = True Then flag = 1 Else flag = 0
mnuStart.Enabled = False
End Sub
'玩家走棋
Private Sub image3_Click(Index As Integer)
If Grid(Index) <> 0 Then Exit Sub
Counter = Counter + 1
If Firstmoved = 0 Then
Image3(Index) = Image1(1 - flag)
Else
Image3(Index) = Image1(flag)
End If
Grid(Index) = 1 + flag
Order(Counter) = Index
mnuBack.Enabled = True
mnuComeback.Enabled = False
r = 0
LineGen Index, (1 + flag * 5)
If LineWin(1 + flag * 5) = + flag * 5 Then
If flag = 0 Then MsgBox "您赢了!" Else MsgBox "您输了!"
Ini
Exit Sub
End If
If Counter = Then
MsgBox "和棋"
Ini
Exit Sub
End If
If mnuComputer.Checked = True Then ComputerMove Else flag = 1 - flag
End Sub
'查找可以落子的空位
Function FindBlank() As Integer
Dim wz, fs, lz, RndNum As Integer
fs = -
For wz = 0 To
If Grid(wz) = 0 Then
Grid(wz) = 2
LineGen wz, 6
Rt = Gen
If Rt > fs Then fs = Rt: lz = wz
Grid(wz) = 0
LineGen wz, -6
End If
Next wz
FindBlank = lz
End Function
'高级模式
Function Attempt() As Integer
Dim wz As Integer
Rt = LineWin(6)
If Rt < Then Attempt = Rt: Exit Function
Rt = LineWin(1)
If Rt < Then Attempt = Rt: Exit Function
'查找落子位置
Rt = linethree(6)
If Rt < Then Attempt = Rt: Exit Function
Rt = linethree(1)
If Rt < Then
Grid(Tb(0)) = 2
LineGen Tb(0), 6
Rt = Gen: wz = Tb(0)
Grid(Tb(0)) = 0
LineGen Tb(0), -6
Grid(Tb(1)) = 2
LineGen Tb(1), 6
If Rt < Gen Then Rt = Gen: wz = Tb(1)
Grid(Tb(1)) = 0
LineGen Tb(1), -6
Grid(Tb(2)) = 2
LineGen Tb(2), 6
If Rt < Gen Then Rt = Gen: wz = Tb(2)
Grid(Tb(2)) = 0
LineGen Tb(2), -6
Attempt = wz
Exit Function
End If
Rt = FindBlank
If Rt < Then Attempt = Rt: Exit Function
End Function
Private Sub mnuFirst_Click() '先后手
Firstmoved = 1
mnuAfter.Checked = False
mnuFirst.Checked = True
End Sub
Private Sub mnuHigher_Click()
mnuLower.Checked = False
mnuHigher.Checked = True
End Sub
Private Sub mnuLower_Click() '难度
mnuLower.Checked = True
mnuHigher.Checked = False
End Sub
'局势评估
Function LineGen(ij, Piece)
Dim b, e, mun As Integer
I = ij \
J = ij Mod
'横线影响
b = IIf(J - 4 > 0, J - 4, 0)
e = IIf(J > , , J)
For K = b To e
mun = H(I * + K)
If mun < 6 Then Gen = Gen + mun * 2 ^ mun
If mun > 5 And mun Mod 6 = 0 Then mun = mun \ 6 - 1: Gen = Gen - mun * 2 ^ mun
H(I * + K) = H(I * + K) + Piece
mun = H(I * + K)
If mun < 6 Then Gen = Gen - mun * 2 ^ mun
If mun > 5 And mun Mod 6 = 0 Then mun = mun \ 6 - 1: Gen = Gen + mun * 2 ^ mun
Next K
'竖线影响
b = IIf(I - 4 > 0, I - 4, 0)
e = IIf(I > , , I)
For K = b To e
mun = V(K * + J)
If mun < 6 Then Gen = Gen + mun * 2 ^ mun
If mun > 5 And mun Mod 6 = 0 Then mun = mun \ 6 - 1: Gen = Gen - mun * 2 ^ mun
V(K * + J) = V(K * + J) + Piece
mun = V(K * + J)
If mun < 6 Then Gen = Gen - mun * 2 ^ mun
If mun > 5 And mun Mod 6 = 0 Then mun = mun \ 6 - 1: Gen = Gen + mun * 2 ^ mun
Next K
'撇线影响
b = IIf(I - 4 > 0, I - 4, 0)
e = IIf(I > , , I)
b = IIf(b > J + I - IIf(J + 4 > , , J + 4), b, J + I - IIf(J + 4 > , , J + 4))
e = IIf(e > J + I - IIf(J > 4, J, 4), J + I - IIf(J > 4, J, 4), e)
For K = b To e
mun = RL(K * + I + J - K)
If mun < 6 Then Gen = Gen + mun * 2 ^ mun
If mun > 5 And mun Mod 6 = 0 Then mun = mun \ 6 - 1: Gen = Gen - mun * 2 ^ mun
RL(K * + I + J - K) = RL(K * + I + J - K) + Piece
mun = RL(K * + I + J - K)
If mun < 6 Then Gen = Gen - mun * 2 ^ mun
If mun > 5 And mun Mod 6 = 0 Then mun = mun \ 6 - 1: Gen = Gen + mun * 2 ^ mun
Next K
'捺线影响
b = IIf(I - 4 > 0, I - 4, 0)
e = IIf(I > , , I)
b = IIf(b > I - J + IIf(J - 4 > 0, J - 4, 0), b, I - J + IIf(J - 4 > 0, J - 4, 0))
e = IIf(e > I - J + IIf(J > , , J), I - J + IIf(J > , , J), e)
For K = b To e
mun = LR(K * - I + J + K)
If mun < 6 Then Gen = Gen + mun * 2 ^ mun
If mun > 5 And mun Mod 6 = 0 Then mun = mun \ 6 - 1: Gen = Gen - mun * 2 ^ mun
LR(K * - I + J + K) = LR(K * - I + J + K) + Piece
mun = LR(K * - I + J + K)
If mun < 6 Then Gen = Gen - mun * 2 ^ mun
If mun > 5 And mun Mod 6 = 0 Then mun = mun \ 6 - 1: Gen = Gen + mun * 2 ^ mun
Next K
End Function
'是否存在三子一线（可发展成五子联线）
Function linethree(Piece As Integer) As Integer
Dim mun As Integer
linethree =
'三子一线
mun = Piece * 3
For I = 0 To
If H(I) = mun Then
If Grid(I) = 0 Then
If I Mod < Then
If Grid(I + 5) = 0 Then
For K = 1 To 4
If Grid(I + K) = 0 Then
Tb(0) = I + K
Tb(1) = I
Tb(2) = I + 5
linethree = Tb(0)
Exit Function
End If
Next K
End If
End If
End If
End If
If V(I) = mun Then
If Grid(I) = 0 Then
If (I \ ) < Then
If Grid(I + ) = 0 Then
For K = 1 To 4
If Grid(I + K * ) = 0 Then
Tb(0) = I + K *
Tb(1) = I
Tb(2) = I +
linethree = Tb(0)
Exit Function
End If
Next K
End If
End If
End If
End If
If RL(I) = mun Then
If Grid(I) = 0 Then
If (I \ ) < And I Mod > 4 Then
If Grid(I + ) = 0 Then
For K = 1 To 4
If Grid(I + K * ) = 0 Then
Tb(0) = I + K *
Tb(1) = I
Tb(2) = I +
linethree = Tb(0)
Exit Function
End If
Next K
End If
End If
End If
End If
If LR(I) = mun Then
If Grid(I) = 0 Then
If (I \ ) < And I Mod < Then
If Grid(I + ) = 0 Then
For K = 1 To 4
If Grid(I + K * ) = 0 Then
Tb(0) = I + K *
Tb(1) = I
Tb(2) = I +
linethree = Tb(0)
Exit Function
End If
Next K
End If
End If
End If
End If
Next I
End Function
Private Sub munHelp_Click() '帮助
lblHelp.Visible = True
End Sub
