vbwuziqi.txt

VB五子棋,棋盘和棋子需要的化电子邮箱告诉我!

'五子棋程序 人机对战版本
'需要2个Label控件   2个CommandButton控件

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

'Dim PlayStep() As String       '记录棋谱的数组
'Dim Label2Cap As String
Private Const BoxL As Single = 50, BoxT As Single = 50, BoxW As Single = 25, BoxN As Integer = 18

Dim Table() As Long             '棋盘(0-BoxN,0-BoxN)     0-空 1-黑子 2-白子
Dim PsCore() As Long            '定义当前玩家桌面空格的分数
Dim CsCore() As Long            '定义当前电脑桌面空格的分数
Dim pWin() As Boolean           '定义玩家的获胜组合
Dim cWin() As Boolean           '定义电脑的获胜组合
Dim pFlag() As Boolean          '定义玩家的获胜组合标志
Dim cFlag() As Boolean          '定义电脑的获胜组合标志
Dim ThePlayFlag As Boolean      '定义游戏有效标志









Private Sub Command1_Click()
     If Not ThePlayFlag Then Call InitPlayEnvironment: Exit Sub
     If MsgBox("本局还没有下完，是否重新开始？(Y/N)", vbYesNo) = vbNo Then Exit Sub
     Call InitPlayEnvironment
End Sub








Private Sub Command2_Click()
     End
End Sub

Private Sub Form_Load()
   Dim i As Long, lw As Long, lh As Long
     'Label2Cap = "000   黑方    行 00    列 00"
     Me.Width = 10815: Me.Height = 8040: Me.Caption = "五子棋 - 人机对战": Me.Show
     lw = Me.Width \ Screen.TwipsPerPixelX: lh = Me.Height \ Screen.TwipsPerPixelY
     SetWindowRgn Me.hWnd, CreateRoundRectRgn(0, 0, lw, lh, 60, 60), True
     With Label1
        .Alignment = vbCenter: .FontSize = 12: .FontBold = True
        .ForeColor = vbRed: .BackStyle = 0: .AutoSize = True: .Move 8910, 510
     End With
     Label2.AutoSize = True: Label2.WordWrap = True
     Label2.BackStyle = 0: Label2.Move 8040, 1050, 2280
     Command1.Move 8025, 7035, 1020, 435: Command1.Caption = "再来一局"
     Command2.Move 9300, 7035, 1020, 435: Command2.Caption = "不玩了"
     Call DrawChessBoard: Me.FillStyle = 0: Call InitPlayEnvironment
End Sub



Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
     End
End Sub











Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Dim iRow As Long, iCol As Long, i As Long, k As Long, t As String
     If Not ThePlayFlag Then Exit Sub
     If Button = vbLeftButton Then    '左键下棋
        iRow = -1: iCol = -1
        For i = 0 To BoxN     '鼠标必须落在交叉点 半径10以内 若是则给出行列号
           If (Y + 10) > (BoxT + i * BoxW) And (Y - 10) <= (BoxT + i * BoxW) Then iRow = i
           If (X + 10) > (BoxL + i * BoxW) And (X - 10) <= (BoxL + i * BoxW) Then iCol = i
        Next
        If (iRow = -1) Or (iCol = -1) Then Beep: Exit Sub
        If Table(iCol, iRow) > 0 Then Exit Sub
        Table(iCol, iRow) = 2: Label1.Caption = "下一步 黑方"
        Me.FillColor = vbWhite: Me.Circle (iCol * BoxW + BoxT, iRow * BoxW + BoxL), 8
        For i = 0 To UBound(cWin, 3)
           If cWin(iCol, iRow, i) = True Then cFlag(i) = False
        Next
        Call CheckWin: Call DianNao    '检查当前玩家是否获胜 调用电脑算法
     End If
End Sub











Public Sub InitPlayEnvironment()
'*****************************************************************************
' 模块名称: InitPlayEnvironment   [初始化过程]
'
' 描述:   1. 设置背景音乐。               2. 设置游戏状态有效。
'         3. 初始化游戏状态标签。         4. 直接指定电脑的第一步走法。
'         5. 初始化基本得分桌面。         6. 电脑和玩家获胜标志初始化。
'         7. 初始化所有获胜组合。         8. 重新设定玩家的获胜标志。
'*****************************************************************************
   Dim i As Long, j As Long, m As Long, n As Long

     ThePlayFlag = True: Label1.Caption = "下一步 白方": Label2.Caption = ""
     Me.FillColor = vbBlack: Me.FillStyle = 0: Me.AutoRedraw = True
     Me.Cls: Me.Circle (9 * BoxW + BoxL, 9 * BoxW + BoxT), 8
     ReDim Table(0 To BoxN, 0 To BoxN) As Long
     ReDim pFlag(NumsWin(BoxN + 1) - 1) As Boolean
     ReDim cFlag(UBound(pFlag)) As Boolean
     ReDim PsCore(BoxN, BoxN) As Long, CsCore(BoxN, BoxN) As Long
     ReDim pWin(BoxN, BoxN, UBound(pFlag)) As Boolean
     ReDim cWin(BoxN, BoxN, UBound(pFlag)) As Boolean
    
     For i = 0 To UBound(pFlag): pFlag(i) = True: cFlag(i) = True: Next
     Table(9, 9) = 1     '假定电脑先手 并下了(9, 9)位 将其值设为1
     '******** 初始化获胜组合 ****************************************
     For i = 0 To BoxN: For j = 0 To BoxN - 4
        For m = 0 To 4
           pWin(j + m, i, n) = True: cWin(j + m, i, n) = True
        Next
        n = n + 1
     Next: Next
     For i = 0 To BoxN: For j = 0 To BoxN - 4
        For m = 0 To 4
           pWin(i, j + m, n) = True: cWin(i, j + m, n) = True
        Next
        n = n + 1
     Next: Next
     For i = 0 To BoxN - 4: For j = 0 To BoxN - 4
        For m = 0 To 4
           pWin(j + m, i + m, n) = True: cWin(j + m, i + m, n) = True
        Next
        n = n + 1
     Next: Next
     For i = 0 To BoxN - 4: For j = BoxN To 4 Step -1
        For m = 0 To 4
           pWin(j - m, i + m, n) = True: cWin(j - m, i + m, n) = True
        Next
        n = n + 1
     Next: Next
     '******** 初始化获胜组合结束 *************************************
     For i = 0 To UBound(pWin, 3) '由于电脑已下了(9, 9)位 所以需要重新设定玩家的获胜标志
         If pWin(9, 9, i) = True Then pFlag(i) = False
     Next
     End Sub
















Public Function DrawChessBoard() As Long
'容器的(BoxL, BoxT)为左上角坐标画一个 BoxN*BoxN, 每格边长为 BoxW 象素的棋盘
   Dim i As Long, j As Long, cx As Long, cy As Long
     Me.ScaleMode = 3: Me.FillStyle = 1: Me.AutoRedraw = True: Me.Cls
     For i = 0 To BoxN   '画棋盘
        Me.Line (BoxL + i * BoxW, BoxT)-(BoxL + i * BoxW, BoxT + BoxN * BoxW)
        Me.Line (BoxL, BoxT + i * BoxW)-(BoxL + BoxN * BoxW, BoxT + i * BoxW)
        Me.CurrentX = BoxL + i * BoxW - IIf(i > 9, 6, 2)
        Me.CurrentY = BoxT - 20: Me.Print Format(i)
        Me.CurrentX = BoxL - IIf(i > 9, 23, 20)
        Me.CurrentY = BoxT + i * BoxW - 6: Me.Print Format(i)
     Next
     For i = 3 To 16 Step 6: For j = 3 To 16 Step 6   '画小标志
        cx = BoxL + j * BoxW - 3: cy = BoxT + i * BoxW - 3
        Me.Line (cx, cy)-(cx + 6, cy + 6), , B
     Next: Next
     Me.AutoRedraw = False: Set Me.Picture = Me.Image
End Function









Public Sub CheckWin()
'*****************************************************************************
' 模块名称:   CheckWin    [获胜检查算法]
'
' 描述:    1. 检查是否和棋。   2. 检查电脑是否获胜。    3. 检查玩家是否获胜。
'*****************************************************************************
   Dim i As Long, j As Long, k As Long, m As Long, n As Long
   Dim cA As Long, pA As Long, cN As Long
    
     For i = 0 To UBound(cFlag): cN = IIf(cFlag(i) = False, cN + 1, cN): Next
    
     If cN = UBound(cFlag) - 1 Then   '设定和棋规则
        Label1.Caption = "双方和棋！": ThePlayFlag = False: Exit Sub
     End If
     For i = 0 To UBound(cFlag)       '检查电脑是否获胜
        If cFlag(i) = True Then
           cA = 0: For j = 0 To BoxN: For k = 0 To BoxN
              If Table(j, k) = 1 And cWin(j, k, i) = True Then cA = cA + 1
           Next: Next
           If cA = 5 Then Label1.Caption = "电脑获胜！": ThePlayFlag = False: Exit Sub
        End If
     Next
     For i = 0 To UBound(pFlag)       '检查玩家是否获胜
        If pFlag(i) = True Then
           pA = 0: For j = 0 To BoxN: For k = 0 To BoxN
              If Table(j, k) = 2 And pWin(j, k, i) = True Then pA = pA + 1
           Next: Next
           If pA = 5 Then Label1.Caption = "玩家获胜！": ThePlayFlag = False: Exit Sub
        End If
     Next
End Sub











Public Sub DianNao()
'*****************************************************************************
' 模块名称:   DianNao      [电脑算法]

' 描述:    1. 初始化赋值系统。    2. 赋值加强算法。      3. 计算电脑和玩家的最佳攻击位。
'          4. 比较电脑和玩家的最佳攻击位并决定电脑的最佳策略。    5. 执行检查获胜函数。
'*****************************************************************************
   Dim i As Long, j As Long, k As Long, m As Long, n As Long
   Dim Dc As Long, cAb As Long, pAb As Long

     ReDim PsCore(BoxN, BoxN) As Long, CsCore(BoxN, BoxN) As Long     '初始化赋值数组
    
     '******** 电脑加强算法 ********
     For i = 0 To UBound(cFlag)
        If cFlag(i) = True Then
           cAb = 0
           For j = 0 To BoxN: For k = 0 To BoxN
              If Table(j, k) = 1 And cWin(j, k, i) = True Then cAb = cAb + 1
           Next: Next
           Select Case cAb
              Case 3
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If Table(m, n) = 0 And cWin(m, n, i) = True Then CsCore(m, n) = CsCore(m, n) + 5
                 Next: Next
              Case 4
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If Table(m, n) = 0 And cWin(m, n, i) = True Then
                       Table(m, n) = 1: Label1.Caption = "下一步 白方"
                       Me.FillColor = vbBlack: Me.Circle (m * BoxW + BoxL, n * BoxW + BoxT), 8
                       For Dc = 0 To UBound(pWin, 3)
                          If pWin(m, n, Dc) = True Then pFlag(Dc) = False: Call CheckWin: Exit Sub
                       Next
                    End If
                 Next: Next
           End Select
        End If
     Next

     For i = 0 To UBound(pFlag)
        If pFlag(i) = True Then
           pAb = 0
           For j = 0 To BoxN: For k = 0 To BoxN
              If Table(j, k) = 2 And pWin(j, k, i) = True Then pAb = pAb + 1
           Next: Next
           Select Case pAb
              Case 3
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If Table(m, n) = 0 And pWin(m, n, i) = True Then PsCore(m, n) = PsCore(m, n) + 30
                 Next: Next
              Case 4
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If Table(m, n) = 0 And pWin(m, n, i) = True Then
                       Table(m, n) = 1: Label1.Caption = "下一步 白方"
                       Me.FillColor = vbBlack: Me.Circle (m * BoxW + BoxL, n * BoxW + BoxT), 8
                       For Dc = 0 To UBound(pWin, 3)
                          If pWin(m, n, Dc) = True Then pFlag(Dc) = False: Call CheckWin: Exit Sub
                       Next
                    End If
                  Next: Next
           End Select
        End If
     Next
     '******** 电脑加强算法结束 ********











     '******** 赋值系统 ****************
     For i = 0 To UBound(cFlag)
        If cFlag(i) = True Then
           For j = 0 To BoxN: For k = 0 To BoxN
              If (Table(j, k) = 0) And cWin(j, k, i) Then
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If (Table(m, n) = 1) And cWin(m, n, i) Then CsCore(j, k) = CsCore(j, k) + 1
                 Next: Next
              End If
           Next: Next
        End If
     Next
        
     For i = 0 To UBound(pFlag)
        If pFlag(i) = True Then
           For j = 0 To BoxN: For k = 0 To BoxN
              If (Table(j, k) = 0) And pWin(j, k, i) Then
                 For m = 0 To BoxN: For n = 0 To BoxN
                    If (Table(m, n) = 2) And pWin(m, n, i) Then PsCore(j, k) = PsCore(j, k) + 1
                 Next: Next
              End If
           Next: Next
        End If
     Next
     '******** 赋值系统结束 ************










     '******** 分值比较算法 ************
   Dim a As Long, b As Long, c As Long, d As Long
   Dim cS As Long, pS As Long

     For i = 0 To BoxN: For j = 0 To BoxN
        If CsCore(i, j) > cS Then cS = CsCore(i, j): a = i: b = j
     Next: Next
     For i = 0 To BoxN: For j = 0 To BoxN
        If PsCore(i, j) > pS Then pS = PsCore(i, j): c = i: d = j
     Next: Next
    
     If cS > pS Then
        Table(a, b) = 1: Label1.Caption = "下一步 白方"
        Me.FillColor = vbBlack: Me.Circle (a * BoxW + BoxL, b * BoxW + BoxT), 8
        For i = 0 To UBound(pWin, 3)
           If pWin(a, b, i) = True Then pFlag(i) = False
        Next
     Else
        Table(c, d) = 1: Label1.Caption = "下一步 白方"
        Me.FillColor = vbBlack: Me.Circle (c * BoxW + BoxL, d * BoxW + BoxL), 8
        For i = 0 To UBound(pWin, 3)
           If pWin(c, d, i) = True Then pFlag(i) = False
        Next
     End If
     '******** 分值比较算法结束 ********
        
     Call CheckWin

End Sub














Public Function NumsWin(ByVal n As Long) As Long
'根据输入的棋盘布局 n*n   计算总共有多少种获胜组合
'假定棋盘为 10 * 10 相应的棋盘数组就是 Table(9, 9)
'水平方向 每一列获胜组合是6 共10列 6*10=60
'垂直方向 每一行获胜组合是6 共10行 8*10=60
'正对角线方向 6 + (5 + 4 + 3 + 2 + 1) * 2 = 36
'反对角线方向 6 + (5 + 4 + 3 + 2 + 1) * 2 = 36
'总的获胜组合数为 60 + 60 + 36 + 36 = 192
   Dim i As Long, t As Long
     For i = n - 5 To 1 Step -1: t = t + i: Next
     NumsWin = 2 * (2 * t + n - 4) + 2 * n * (n - 4)