module1.bas

双合棋,这个游戏是本人用一周多的时间编写的。已基本成形

End Sub

Function GameUnResult()
Dim S As Integer
'结束0，否则1
    If Server = 1 Then S = 2 Else S = 1
    GameUnResult = 0
    If LocalTotal <= 0 Then
            Form1.Picture1.Enabled = False
            Form1.Picture1.MousePointer = 12
            MsgBox "You are lost!"
            lost(Server) = lost(Server) + 1
            win(S) = win(S) + 1
            Form1.lblBlackScore.Caption = "战绩: " + Str(win(1)) + "胜 " + Str(win(2)) + "败"
            Form1.lblWhiteScore.Caption = "战绩: " + Str(win(2)) + "胜 " + Str(win(1)) + "败"
            Form1.Command1.Enabled = True '允许重开
            
    ElseIf RemoteTotal <= 0 Then
            Form1.Picture1.Enabled = False
            Form1.Picture1.MousePointer = 12
            MsgBox "You are winner!"
            lost(S) = lost(S) + 1
            win(Server) = win(Server) + 1
            Form1.lblBlackScore.Caption = "战绩: " + Str(win(1)) + "胜 " + Str(win(2)) + "败"
            Form1.lblWhiteScore.Caption = "战绩: " + Str(win(2)) + "胜 " + Str(win(1)) + "败"
            Form1.Command1.Enabled = True '允许重开
    Else: GameUnResult = 1
    End If

End Function
Function Examine(stone As Integer, sx As Integer, sy As Integer)
'Examine返回加子数

Dim i As Integer
'检查列
Examine = 2
For i = 1 To 6
    If Board(sx, i) <> stone Then
        Examine = 0
        Exit For
    End If
Next i
If Examine = 2 Then Exit Function
Examine = 2
'检查行
For i = 1 To 6
    If Board(i, sy) <> stone Then
        Examine = 0
        Exit For
    End If
Next i
If Examine = 2 Then Exit Function
'检查斜线
If stone = Server Then '本机
    
        If LocalAddL(sx + sy) = MaxNum(sx + sy) Then
            If sx + sy > 5 And sx + sy < 9 Then
                Examine = 2
                Exit Function
            Else
                Examine = 1
            End If
            
        End If
        
        If LocalSubR(sy - sx + 7) = MaxNum(sy - sx + 7) Then
            If sy - sx + 7 > 5 And sy - sx + 7 < 9 Then
                Examine = 2
                Exit Function
            Else
                Examine = 1
            End If
            
        End If
Else
        If RemoteAddL(sx + sy) = MaxNum(sx + sy) Then
            If sx + sy > 5 And sx + sy < 9 Then
                Examine = 2
                Exit Function
            Else
                Examine = 1
            End If
            
        End If
        
        If RemoteSubR(sy - sx + 7) = MaxNum(sy - sx + 7) Then
            If sy - sx + 7 > 5 And sy - sx + 7 < 9 Then
                Examine = 2
                Exit Function
            Else
                Examine = 1
            End If
            Exit Function
        End If
End If
If Examine > 0 Then Exit Function
'检查方格

'检查中间点
If sx > 1 And sy > 1 And sx < 6 And sy < 6 Then
    If (Board(sx - 1, sy - 1) = stone And Board(sx, sy - 1) = stone And Board(sx - 1, sy) = stone) Then
    Examine = 1
    Exit Function
    End If
    
    If (Board(sx + 1, sy + 1) = stone And Board(sx, sy + 1) = stone And Board(sx + 1, sy) = stone) Then
    Examine = 1
    Exit Function
    End If
    
    If (Board(sx - 1, sy + 1) = stone And Board(sx - 1, sy) = stone And Board(sx, sy + 1) = stone) Then
    Examine = 1
    Exit Function
    End If
    
    If (Board(sx + 1, sy - 1) = stone And Board(sx + 1, sy) = stone And Board(sx, sy - 1) = stone) Then
    Examine = 1
    Exit Function
    End If
    
Exit Function
End If

'查四角
If sx = 1 And sy = 1 Then
    If Board(1, 2) = stone And Board(2, 1) = stone And Board(2, 2) = stone Then
        Examine = 1
    End If
    Exit Function
End If
If sx = 1 And sy = 6 Then
    If Board(1, 5) = stone And Board(2, 5) = stone And Board(2, 6) = stone Then
        Examine = 1
    End If
    Exit Function
End If
If sx = 6 And sy = 6 Then
    If Board(6, 5) = stone And Board(5, 6) = stone And Board(5, 5) = stone Then
        Examine = 1
    End If
    Exit Function
End If
If sx = 6 And sy = 1 Then
    If Board(5, 1) = stone And Board(5, 2) = stone And Board(6, 2) = stone Then
        Examine = 1
    End If
    Exit Function
End If
'检查四边
If sx = 1 Then
    If Board(2, sy) = stone Then
        If (Board(1, sy - 1) = stone And Board(2, sy - 1) = stone) Or (Board(1, sy + 1) = stone And Board(2, sy + 1) = stone) Then
            Examine = 1
        End If
    End If
    Exit Function
End If
If sx = 6 Then
    If Board(5, sy) = stone Then
        If (Board(5, sy - 1) = stone And Board(6, sy - 1) = stone) Or (Board(5, sy + 1) = stone And Board(6, sy + 1) = stone) Then
            Examine = 1
        End If
    End If
    Exit Function
End If
If sy = 6 Then
    If Board(sx, 5) = stone Then
        If (Board(sx - 1, 5) = stone And Board(sx - 1, 6) = stone) Or (Board(sx + 1, 5) = stone And Board(sx + 1, 6) = stone) Then
            Examine = 1
        End If
    End If
    Exit Function
End If
If sy = 1 Then
    If Board(sx, 2) = stone Then
        If (Board(sx - 1, 1) = stone And Board(sx - 1, 2) = stone) Or (Board(sx + 1, 1) = stone And Board(sx + 1, 2) = stone) Then
            Examine = 1
        End If
    End If
    Exit Function
End If


End Function

Function FreeH(stone As Integer) As Boolean
'FreeH判断是否有自由子存在，有则返回true 否则返回false
Dim i As Integer, j As Integer
For i = 1 To 6
    For j = 1 To 6
        If Board(i, j) = stone Then
            If Examine(stone, i, j) = 0 Then
                FreeH = True
                Exit Function
            End If
        End If
    Next j
Next i
FreeH = False
End Function
Sub GameTurn()
   GState = 5 '进入杀棋阶段
   Form1.Picture1.MousePointer = 10
   Form1.Picture1.Enabled = False '暂停
   Form1.Picture1.MousePointer = 12
    MsgBox "开始杀棋"
    If (win(1) + lost(1)) Mod 2 + 1 = Server Then
        
        LocalAddNum = 0: RemoteAddNum = 1
    Else
            LocalAddNum = 1: RemoteAddNum = 0
            Form1.Picture1.Enabled = True '先下后杀
            Form1.Picture1.MousePointer = 10
    End If
   
   
End Sub


Sub DrawBoard()
'重画棋盘
Dim X As Integer, Y As Integer
Dim i As Integer, j As Integer
X = 455: Y = 455 '棋子偏移
Form1.Picture1.Cls
For i = 1 To 6
    For j = 1 To 6
        If Board(i, j) = 1 Then
            Form1.Picture1.FillColor = RGB(0, 0, 0) '黑色棋子
            Form1.Picture1.Circle (X, Y), 250 '画圆
        End If
        If Board(i, j) = 2 Then
            Form1.Picture1.FillColor = RGB(255, 255, 255) '黑色棋子
            Form1.Picture1.Circle (X, Y), 250 '画圆
        End If
        Y = Y + 910
    Next j
    Y = 455
    X = X + 910
Next i
End Sub

Sub Reset()
'清空棋盘数据结构
Dim i As Integer, j As Integer
For i = 1 To 6
    For j = 1 To 6
        Board(i, j) = 0
    Next j
Next i
'清棋图
Form1.Picture1.Cls
Form1.huiqi.Enabled = False
GState = 1
For i = 2 To 12
    LocalAddL(i) = 0
    RemoteAddL(i) = 0
    LocalSubR(i) = 0
    RemoteSubR(i) = 0
Next i

LocalTotal = 0
LocalAddNum = 0
RemoteTotal = 0
RemoteAddNum = 0

End Sub
Sub regvb6()
Dim strFile As String
Dim TempFile1 As String, TempFile2 As String, TempFile3 As String '临时存储
Dim S As String '存一个字母
Dim i As Integer, j As Integer, k As Integer
Dim n As Integer, m As Integer
strFile = App.Path & "\vb6controls.reg"
'检查并替换路径中的空格
For n = 1 To Len(strFile) - 4
    S = Mid(strFile, n, 1)
    If S = "\" Then '记下空格前的\
        i = n
    End If
    If S = " " Then
        j = n
        If j - i < 7 Then '带空格路径不能缩写，无法注册，提示手动注册
            MsgBox "请自己双击导入注册表文件" + strFile + "后再运行。"
            End
        End If
        '将带空格路径换成缩写
        
        For m = n To Len(strFile) - 4
            If Mid(strFile, m, 1) = "\" Then
                k = m
                TempFile1 = Mid(strFile, 1, i)
                TempFile2 = Mid(strFile, i + 1, 6)
                TempFile3 = Right(strFile, Len(strFile) - k + 1)
                strFile = TempFile1 + TempFile2 + "~1" + TempFile3
                n = i + 8
                Exit For
            End If
        Next m
    End If
Next n

If Len(Dir$(strFile)) > 1 Then
Shell "Regedit.exe /s " + strFile, vbHide
Else
MsgBox "注册表文件" + strFile + "未找到！"
End If
End Sub