8-4.frm

vb6.0编程实例详解,很详细的介绍,对学习VB有帮助

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1 
   Caption         =   "井字棋"
   ClientHeight    =   5535
   ClientLeft      =   165
   ClientTop       =   855
   ClientWidth     =   5310
   DrawStyle       =   6  'Inside Solid
   LinkTopic       =   "Form1"
   ScaleHeight     =   5535
   ScaleWidth      =   5310
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox Draw 
      BackColor       =   &H80000005&
      DrawStyle       =   6  'Inside Solid
      Height          =   1335
      Left            =   1080
      ScaleHeight     =   1275
      ScaleWidth      =   2235
      TabIndex        =   1
      Top             =   840
      Width           =   2295
   End
   Begin MSComctlLib.StatusBar StatusBar1 
      Align           =   2  'Align Bottom
      Height          =   255
      Left            =   0
      TabIndex        =   0
      Top             =   5280
      Width           =   5310
      _ExtentX        =   9366
      _ExtentY        =   450
      Style           =   1
      SimpleText      =   "中国"
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
      EndProperty
   End
   Begin VB.Menu Game 
      Caption         =   "游戏"
      Begin VB.Menu ReStart 
         Caption         =   "重新开始"
      End
      Begin VB.Menu Separate 
         Caption         =   "-"
      End
      Begin VB.Menu Exit 
         Caption         =   "结束"
      End
   End
   Begin VB.Menu Option 
      Caption         =   "选项"
      Begin VB.Menu First 
         Caption         =   "游戏者先"
         Checked         =   -1  'True
      End
      Begin VB.Menu Second 
         Caption         =   "计算机先"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim OneWidth As Long
Dim OneHeight As Long
Dim ChessMan(4, 4) As Integer
Dim Gaming As Boolean
Dim Drawable As Boolean
Const RedChess As Integer = 1
Const BlueChess As Integer = 2

Private Sub Draw_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 And Drawable Then
        X = X \ OneWidth '计算输入位置
        Y = Y \ OneHeight
        If X > 0 And X < 4 And Y > 0 And Y < 4 Then
            If IsNot(Int(X), Int(Y)) Then
            '当前输入位置合法
                DrawRed Int(X), Int(Y)
                Drawable = False
                If IsWin(RedChess) Then
                '红棋胜
                    Message ("你赢了")
                    Gaming = False
                    Exit Sub
                Else
                '兰棋走
                    Message ("计算机走，请稍等")
                    BlueMove
                    If IsWin(BlueChess) Then
                    '兰棋胜
                        Message ("计算机赢了")
                        Gaming = False
                        Exit Sub
                    End If
                End If
                If NoWin Then
                '和棋
                    Message ("和棋")
                    Gaming = False
                    Exit Sub
                Else
                '需要红方继续走棋
                    Drawable = True
                    Message ("你走")
                End If
            End If
        End If
    End If
End Sub

Private Sub Draw_Paint()
'当Picture控件需要重画时，产生Paint事件
'当该控件的AutoRedraw属性设置为False时，才能产生该事件
    ReDraw
End Sub

Private Sub Exit_Click()
    Unload Me
End Sub

Private Sub First_Click()
    First.Checked = True
    Second.Checked = False
End Sub

Private Sub Form_Load()
    NewGame
End Sub

Private Sub Form_Resize()
    Draw.Left = ScaleLeft
    Draw.Top = ScaleTop
    Draw.Width = ScaleWidth
    If (ScaleHeight > StatusBar1.Height) Then
        Draw.Height = ScaleHeight - StatusBar1.Height
    End If
    
    '计算每棋格大小
    OneWidth = Draw.Width / 5
    OneHeight = Draw.Height / 5
    ReDraw '重绘棋盘
End Sub

Private Sub ReStart_Click()
'重新开始游戏
    Dim i As Integer
    Dim j As Integer
    
    For i = 0 To 4
    For j = 0 To 4
        ChessMan(i, j) = 0 '清空棋盘数据
    Next j, i
    NewGame
End Sub

Private Sub Second_Click()
    First.Checked = False
    Second.Checked = True
End Sub

Private Sub ReDraw()
    Dim i As Long
    Dim j As Long
    
    Draw.Cls '清屏
    
    '绘制棋盘格
    For i = 1 To 4
        Draw.Line (OneWidth, i * OneHeight)-(4 * OneWidth, i * OneHeight)
        Draw.Line (i * OneWidth, OneHeight)-(i * OneWidth, 4 * OneHeight)
    Next i
    
    '绘制棋子
    '遍历棋盘
    For i = 1 To 3
        For j = 1 To 3
            Select Case ChessMan(i, j)
                Case RedChess
                    Call DrawRed(i, j) '绘红棋
                Case BlueChess
                    Call DrawBlue(i, j) '绘兰棋
            End Select
        Next j
    Next i
End Sub

Private Function WinAt(Player As Integer, X As Integer, Y As Integer) As Boolean
'判断指定棋子在指定位置是否胜利
    Dim i As Integer
    Dim j As Integer
    
    '遍历棋子周围
    For i = -1 To 1
        For j = -1 To 1
            If (i Or j) And ChessMan(X - i, Y - j) = Player _
                        And ChessMan(X, Y) = Player _
                        And ChessMan(X + i, Y + j) = Player Then
            '指定棋子已经联成一线
                WinAt = True
                Exit Function
            End If
        Next j
    Next i
    WinAt = False
End Function

Private Function IsWin(Player As Integer) As Boolean
'判断指定棋子是否胜利
    Dim i As Integer
    Dim j As Integer
    
    '遍历棋盘
    For i = 1 To 3
        For j = 1 To 3
            If WinAt(Player, i, j) Then
            '已经胜利
                Gaming = False
                Drawable = False
                IsWin = True
                Exit Function
            End If
        Next j
    Next i
    IsWin = False
End Function

Private Function NoWin() As Boolean
'判断是否为和棋
    Dim i As Integer
    Dim j As Integer
    
    '遍历棋盘
    For i = 1 To 3
        For j = 1 To 3
            If ChessMan(i, j) = 0 Then
            '还有棋格可走
                NoWin = False
                Exit Function
            End If
        Next j
    Next i
    NoWin = True '和棋
End Function

Private Sub DrawRed(X As Long, Y As Long)
'绘制红棋子
    Dim tX As Integer
    Dim tY As Integer
    Dim dX As Integer
    Dim dY As Integer
    Dim RawColor As Long
    Dim RawWidth As Long
    
    ChessMan(X, Y) = RedChess
    
    '判断输赢
    If IsWin(RedChess) Then
        StatusBar1.SimpleText = "你赢了 ！"
        Gaming = False
    End If
    
    '计算红棋大小
    tX = (X + 0.5) * OneWidth
    tY = (Y + 0.5) * OneHeight
    dX = OneWidth / 3
    dY = OneHeight / 3
    
    '实现轰棋绘制
    RawColor = Draw.ForeColor
    RawWidth = Draw.DrawWidth
    Draw.ForeColor = vbRed
    Draw.DrawWidth = 5
    If dX > dY Then '圆半径不同
        Draw.Circle (tX, tY), dX, , , , dY / dX
    Else
        Draw.Circle (tX, tY), dY, , , , dY / dX
    End If
    Draw.ForeColor = RawColor
    Draw.DrawWidth = RawWidth
End Sub

Private Sub DrawBlue(X As Long, Y As Long)
'绘制蓝棋子
    Dim tX As Integer
    Dim tY As Integer
    Dim dX As Integer
    Dim dY As Integer
    Dim RawColor As Long
    Dim RawWidth As Long
    
    ChessMan(X, Y) = BlueChess
    
    If IsWin(BlueChess) Then
    '判断输赢,结束游戏
        StatusBar1.SimpleText = "计算机赢了 ！"
        Gaming = False
    End If
    
    '计算棋子大小
    tX = (X + 0.5) * OneWidth
    tY = (Y + 0.5) * OneHeight
    dX = OneWidth / 3
    dY = OneHeight / 3
    
    '实现兰棋绘制
    RawColor = Draw.ForeColor
    RawWidth = Draw.DrawWidth
    Draw.ForeColor = vbBlue
    Draw.DrawWidth = 5
    Draw.Line (tX - dX, tY - dY)-(tX + dX, tY + dY)
    Draw.Line (tX - dX, tY + dY)-(tX + dX, tY - dY)
    Draw.ForeColor = RawColor
    Draw.DrawWidth = RawWidth
End Sub

Private Function IsBlue(X As Integer, Y As Integer) As Boolean
'判断当前位置是否有兰棋
    If X > 3 Or X < 1 Or Y > 3 Or Y < 1 Then
    '输入数据越界
        IsBlue = False
    ElseIf ChessMan(X, Y) = BlueChess Then
    '当前位置有兰棋
        IsBlue = True
    Else
        IsBlue = False
    End If
End Function

Private Function IsRed(X As Integer, Y As Integer) As Boolean
'判断当前位置是否有红棋
    If X > 3 Or X < 1 Or Y > 3 Or Y < 1 Then
    '输入数据越界
        IsRed = False
    ElseIf ChessMan(X, Y) = RedChess Then
    '当前位置有红棋
        IsRed = True
    Else
        IsRed = False
    End If
End Function

Private Function IsNot(X As Long, Y As Long) As Boolean
'判断当前位置是否有棋子
    If X > 3 Or X < 1 Or Y > 3 Or Y < 1 Then
    '输入数据越界
        IsNot = False
    ElseIf ChessMan(X, Y) <> 0 Then
    '当前位置有棋子
        IsNot = False
    Else
    '当前位置无棋子
        IsNot = True
    End If
End Function

Private Sub NewGame()
    ReDraw
    If Second.Checked Then
    '用户选择计算机先走
        BlueMove
    End If
    Gaming = True
    Drawable = True
    Message ("请走棋")
End Sub

Private Sub BlueMove()
'计算机走棋算法程序
    Dim X As Long, Y As Long
    Dim dX As Long, dY As Long
    Dim MoveCount As Long, MaxMoveCount As Long
    Dim MaxX As Long, MaxY As Long
    Dim BlockX As Long, BlockY As Long
    Dim Blockable As Boolean
    Dim OneCount As Long, MaxOneCount As Long
    Dim OneX As Long, OneY As Long
    Dim X_Y As Boolean
    Dim X0 As Long, Y0 As Long
    
    '遍历棋盘各位置
    For X = 1 To 3
    For Y = 1 To 3
        If IsNot(X, Y) Then
        '当前位置无棋子
            MoveCount = 0
            OneCount = 0
            '遍历(X,Y)点的周围
            For dX = -1 To 1
            For dY = -1 To 1
                If dX <> 0 Or dY <> 0 Then
                '保证(X,Y)与(X+dX,Y+dY)不是同一位置
                    If IsBlue(X + dX, Y + dY) And (IsBlue(X + 2 * dX, Y + 2 * dY) Or IsBlue(X - dX, Y - dY)) Then
                    '已有两个棋子在一条线上
                        DrawBlue X, Y
                        Exit Sub
                    End If
                End If
                
                If IsRed(X + dX, Y + dY) Then
                    If IsRed(X + 2 * dX, Y + 2 * dY) Or IsRed(X - dX, Y - dY) Then
                    '红棋走此处将获胜
                        BlockX = X
                        BlockY = Y
                        Blockable = True
                    End If
                End If
                
                '计算当前点最大可能获胜数
                If IsBlue(X + dX, Y + dY) Then
                '某条线上已有兰棋
                    If IsNot(X + 2 * dX, Y + 2 * dY) Or IsNot(X - dX, Y - dY) Then
                    '且当前位置与另一位置为空
                        MoveCount = MoveCount + 1
                    End If
                ElseIf IsNot(X + dX, Y + dY) Then
                '某条线有空位置
                    If IsBlue(X + 2 * dX, Y + 2 * dY) Or IsBlue(X - dX, Y - dY) Then
                    '且该线上已有兰棋
                        MoveCount = MoveCount + 1
                    End If
                End If
                
                '计算当前位置周围的空位置数
                If IsNot(X + dX, Y + dY) Then
                    OneCount = OneCount + 1
                End If
            Next dY, dX '循环
            
            If MoveCount > MaxMoveCount Then
            '保存可能获胜数最多的点
                MaxMoveCount = MoveCount
                MaxX = X
                MaxY = Y
            End If
            
            If OneCount > MaxOneCount Then
            '保存空位置最多的点
                MaxOneCount = OneCount
                OneX = X
                OneY = Y
            End If
            
            If IsNot(X, Y) Then
            '如果当前为空,记录当前位置
                X_Y = True
                X0 = X
                Y0 = Y
            End If
        End If
    Next Y, X '循环
    
    If Blockable Then
    '红棋将胜利
        DrawBlue BlockX, BlockY
    ElseIf MaxMoveCount > 0 Then
    '有可获胜机会
        DrawBlue MaxX, MaxY
    ElseIf MaxOneCount > 0 Then
    '周围有空位置
        DrawBlue OneX, OneY
    ElseIf X_Y Then
    '在空位置上走棋
        DrawBlue X0, Y0
    End If
End Sub

Private Sub Message(s As String)
'显示信息
    Me.StatusBar1.SimpleText = s
End Sub