连连看处理.bas

用VB写的连连看游戏

    flag1 = flag
    Do While flag1 <= 4
        If htjc(flag1) = 0 Then
            u = ts(X, Y, flag1)
            If u = 2 Then
                ''''''''''''''''''''''''''''''''''''''''
                If stack_n > 3 Then
                    If flag1 = stack(stack_n - 1).flag Then
                        uk = stack(stack_n - 1).n
                        q = 0
                    Else
                        uk = stack(stack_n - 1).n + 1
                        q = 1
                    End If
                    k = push(X, Y, flag1, q, uk)
                    For i = 1 To stack_n - 2
                        If stack(i).flag <> stack(i + 1).flag Then n2 = n2 + 1
                    Next i
                    If n2 <= 2 Then
                        k = push(X, Y, flag1, 0, 0)
                        Call delete(mousedo.x1, mousedo.y1, mousedo.x2, mousedo.y2)
                        Exit Sub
                    Else
                        Call pop
                    End If
                Else
                    k = push(X, Y, flag1, 0, 0)
                    Call delete(mousedo.x1, mousedo.y1, mousedo.x2, mousedo.y2)
                    Exit Sub
                End If
                ''''''''''''''''''''''''''''''''
            End If
            flag1 = flag1 + 1
        Else
            flag1 = flag1 + 1
        End If
    Loop
    ''''''''''''''''''''''''''''''''''
    Do While flag <= 4       '直到所有的方向全部都探测过
        If htjc(flag) = 0 Then    '如果没有重复方向
            m = ts(X, Y, flag)
            Select Case m
                Case 0       '如果存在活方向
                    If stack_n >= 4 Then
                        k = push(X, Y, flag, 0, 0)    '改动1
                        For i = 1 To stack_n - 2
                            If stack(i).flag <> stack(i + 1).flag Then n1 = n1 + 1
                        Next i
                        If n1 > 2 Then GoTo ax
                        If stack(stack_n - 2).flag = stack(stack_n - 1).flag Then    '如果探测的方向和原来探测的方向相同
                            wd = 0    'wd为0表示该点不是一个弯点
                        Else
                            wd = 1    'wd为1表示是一个弯点
                        End If
                    End If
                    If n1 = 2 Then
                        If stack(stack_n - 1).flag = flag Then
                            k = push(X, Y, flag, wd, n1)
                            ret1.flag = flag: ret1.X = xfx(X, flag): ret1.Y = yfx(Y, flag)    '得到下一探测点的坐标
                            Exit Sub
                        Else
                            flag = flag + 1
                        End If
                    Else
                        k = push(X, Y, flag, wd, n1)
                        ret1.flag = 1: ret1.X = xfx(X, flag): ret1.Y = yfx(Y, flag)    '得到下一探测点的坐标
                        Exit Sub
                    End If
                Case 2       '(如果是连接上,进行消去图块处理,现在为调试阶段)
                    k = push(X, Y, flag, 0, 2)    '改动
                    ''''''''''''''''''''''''''''''''''''''''
                    For i = 1 To stack_n - 2
                        If stack(i).flag <> stack(i + 1).flag Then n4 = n4 + 1
                    Next i
                    If n4 <= 2 Then
                        ret1.X = 0: ret1.Y = 0: ret1.flag = 0: ret1.n = 0: ret1.wd = 0
                        Exit Sub
                    Else
                        Call pop
                        ret1.X = popret.X: ret1.Y = popret.Y: ret1.flag = popret.flag + 1: ret1.n = popret.n: ret1.wd = popret.wd
                        Exit Sub
                    End If
                Case 1       '如果是一个死方向
                    flag = flag + 1
            End Select
        Else                 '否则方向重复的话继续顺时针改变方向
            flag = flag + 1
        End If
    Loop
    '循环结束(所有方向都探测过了)没有结果表示该点是一个死位置,需要退栈操作
    '1:是1次弯的退栈只需要退1格.2:是二次弯的退栈需要退到第个弯点
    '退栈后并且得到下一个探测的点
    If stack_n >= 2 Then
        Call pop
        ret1.X = popret.X: ret1.Y = popret.Y: ret1.flag = popret.flag + 1: ret1.wd = popret.wd: ret1.n = popret.n
    Else
        ret1.X = X: ret1.Y = Y: ret1.flag = flag + 1: ret1.wd = 0: ret1.n = 0
    End If
    Exit Sub
ax:                          '退栈的第二种情况
    Call pop
    ret1.X = popret.X: ret1.Y = popret.Y: ret1.flag = popret.flag + 1: ret1.wd = popret.wd: ret1.n = 1
End Sub
'''''''''''''''''''''''''''''
'判断函数的初始化
''''''''''''''''''''''''''''''
Sub init()
    ret1.X = 0: ret1.Y = 0: ret1.n = 0: ret1.wd = 0: ret1.flag = 0
    popret.X = 0: popret.Y = 0: popret.n = 0: popret.wd = 0: popret.flag = 0
    gettopret.X = 0: gettopret.Y = 0: gettopret.n = 0: gettopret.wd = 0: gettopret.flag = 0
    stack_n = 1              '初始化栈
End Sub
'''''''''''''''''''''''''
'删除连接上的图块
'''''''''''''''''''''''''
Sub delete(ByVal X As Integer, ByVal Y As Integer, ByVal x1 As Integer, ByVal y1 As Integer)
    Dim flag, n, i, j As Integer
    For i = 1 To stack_n - 2
        If stack(i).flag <> stack(i + 1).flag Then n = n + 1
    Next i
    '''''''''''''''''''''''
    If stack_n > 3 Then
        flag = stack(stack_n - 1).flag    '如果探测的方向和原来探测的方向相同
        If (mousedo.x1 = xfx(ByVal stack(stack_n - 1).X, ByVal flag) And mousedo.y1 = yfx(ByVal stack(stack_n - 1).Y, ByVal flag)) Or (mousedo.x2 = xfx(ByVal stack(stack_n - 1).X, ByVal flag) And mousedo.y2 = yfx(ByVal stack(stack_n - 1).Y, ByVal flag)) Then
            n = n
        Else
            n = n + 1
        End If
    End If
    ''''''''''''''''''''''
    If n < 3 Then
        If can1 = True Then  '如果是游戏能性测试CAN为TRUE否则为FALSE
            gamenum = gamenum + 1    '连接次数加一
            Call andsound
            '''''''''''''''''''''
            Call killtime    '完成连接效果
            ''''''''''''''''''''
            jl(X, Y).flag = 0
            jl(x1, y1).flag = 0
            Call graph
            Call init
            mousedo.x1 = 1: mousedo.y1 = 1: mousedo.x2 = 1: mousedo.y2 = 1
            gametime = gametime + 1    '时间增加
            If gametime > 150 Then gametime = 150    '时间到顶
            Form1.Picture3.PaintPicture Form2.Picture4.Picture, gametime * 3 - 450, 0, 450, 10, , , , , vbSrcCopy
            If gamenum >= 70 Then Call youwin    '胜利处理
        Else
            Call init
        End If
        alrealy = True       '表示已经连接上
    Else
        Call pop
        Call ceshi(popret.X, popret.Y, popret.flag + 1, popret.n)
    End If
End Sub
''''''''''''''''''''''
'帮助模块
''''''''''''''''''''''
Sub help()
''''''''''''''''''''''''''''''''''''
'如果暂停游戏或没有开始游戏屏蔽帮助
''''''''''''''''''''''''''''''''''''
    If playflag = False Or stopflag = True Then
        Exit Sub
    End If
    If helpn <= 0 Then
        Exit Sub
    End If
    ''''''''''''''''''''''''''''''''''''''
    Dim i, j, i1, j1 As Integer
    alrealy = False
    For i = 1 To 11
        For j = 1 To 15
            If jl(i, j).flag = 1 Then
                mousedo.x1 = i: mousedo.y1 = j
                For i1 = i To 11
                    For j1 = 1 To 15
                        If jl(i1, j1).flag = 1 And jl(i1, j1).lx = jl(i, j).lx And (i <> i1 Or j <> j1) Then
                            mousedo.x2 = i1: mousedo.y2 = j1
                            Call ceshi1(mousedo.x1, mousedo.y1, 1, 0)
                            If alrealy = True Then GoTo helpend
                        End If
                    Next j1
                Next i1
            End If
        Next j
    Next i
helpend:
    Call init
    helpn = helpn - 1        '帮助次数减一
    Call abled
End Sub
''''''''''''''''''''''''''''''
'合理检测模块
'''''''''''''''''''''''''''''
Sub abled()
    Dim i, j, i1, j1, x1, y1, x2, y2 As Integer
    alrealy = False
    x1 = mousedo.x1: y1 = mousedo.y1: x2 = mousedo.x2: y2 = mousedo.y2
    can1 = False             '关掉处理功能
    For i = 1 To 11
        For j = 1 To 15
            If jl(i, j).flag = 1 Then
                mousedo.x1 = i: mousedo.y1 = j
                For i1 = i To 11
                    For j1 = 1 To 15
                        If jl(i1, j1).flag = 1 And jl(i1, j1).lx = jl(i, j).lx And (i <> i1 Or j <> j1) Then
                            mousedo.x2 = i1: mousedo.y2 = j1
                            Call ceshi1(mousedo.x1, mousedo.y1, 1, 0)
                            If alrealy = True Then GoTo over
                        End If
                    Next j1
                Next i1
            End If
        Next j
    Next i
    '''''''''''''''''''''''''
    '循环结束表示游戏能性为假
    ''''''''''''''''''''''''''
    Call init
    Call againstar           '重新分配游戏
    can1 = True
    Exit Sub
over:
    can1 = True
    Call init
    mousedo.x1 = x1: mousedo.y1 = y1: mousedo.x2 = x2: mousedo.y2 = y2
End Sub
'''''''''''''''''''''''''
'完成效果连接图
''''''''''''''''''''''''
Sub killtime()
    Dim ai As Integer
    Form1.Picture1.PaintPicture Form2.Picture1(jl(mousedo.x2, mousedo.y2).lx - 1).Picture, 40 * (mousedo.y1 - 1), 40 * (mousedo.x1 - 1), 40, 40, , , , , vbSrcCopy    '还原原来效果
    '画线完成对图形的分割
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For ai = 1 To 12
        Form1.Picture1.Line (40, 40 * ai)-(600, 40 * ai)
    Next ai
    For ai = 1 To 16
        Form1.Picture1.Line (40 * ai, 40)-(40 * ai, 440)
    Next ai
    ''''''''''''''''''''''''''''''''''''''''''''''''''
    Call theway
    Form1.Timer1.Enabled = True
    time1 = 0
    Do While time1 < 2
        DoEvents             '屏蔽中断
    Loop
    Form1.Timer1.Enabled = False
End Sub
Sub againstar() '重新分配游戏
    Dim mun, i, j, tk1(1 To 26), n, m, ret(1 To 141) As Integer
    '''''''''''''''''''''
    '统计出没有连接完的图块
    ''''''''''''''''''''
    For i = 2 To 11
        For j = 2 To 15
            If jl(i, j).flag = 1 Then
                tk1(jl(i, j).lx) = tk1(jl(i, j).lx) + 1
                n = n + 1
                jl(i, j).flag = 0
            End If
        Next j
    Next i
    ''''''''''''''''''''''
    m = 1
    num = 1
    Call ysfh(ret)
    Do While m <= n
        i = (ret(m) - 1) \ 14
        j = ret(m) Mod 14
        If i = 0 Then
            i = 2
        Else
            i = i + 2
        End If
        If j = 0 Then
            j = 15
        Else
            j = j + 1
        End If
        jl(i, j).X = 40 * j
        jl(i, j).Y = 40 * i
        jl(i, j).flag = 1
        Do While tk1(num) = 0 And num < 26
            num = num + 1
        Loop
        jl(i, j).lx = num
        tk1(num) = tk1(num) - 1
        m = m + 1
    Loop
    ''''''''''''''''''''''''''
    Call graph
End Sub
Sub ceshi1(ByVal X As Integer, ByVal Y As Integer, ByVal flag As Integer, ByVal k As Integer)
    Dim starx, stary, endx, endy, wd, n As Integer
    ret1.X = X: ret1.Y = Y: ret1.flag = flag
    Do
        starx = ret1.X: stary = ret1.Y: flag = ret1.flag: k = ret1.n
        Call sdpd(starx, stary, flag, k)
        If ret1.X = 0 And ret1.Y = 0 And ret1.wd = 0 And ret1.flag = 0 And ret1.n = 0 Then
            Exit Sub
        End If
    Loop Until stackempty = 0 And ret1.flag > 4    '直到栈空
End Sub
Sub gametimer()
    If gametime <= 0 Then
        Call youover
    Else
        gametime = gametime - 1
        Form1.Picture3.Cls
        If gametime >= 1 Then
            Form1.Picture3.PaintPicture Form2.Picture4.Picture, gametime * 3 - 450, 0, 450, 10, , , , , vbSrcCopy
        Else
            Form1.Picture3.PaintPicture Form2.Picture4.Picture, 1 - 450, 0, 450, 10, , , , , vbSrcCopy
        End If
    End If
End Sub
Sub youover()
    playflag = False
    Form1.Timer2.Enabled = False    '关闭时间
    overflag = True          '游戏结束
    Form1.Picture3.Cls
    Form1.Picture1.Cls
    Form1.Picture1.PaintPicture Form2.Picture5(0).Picture, 140, 220, 360, 40, , , , , vbSrcCopy
    Form1.Label4.Caption = "继续游戏"
    Form1.Label4.Visible = True
    Form1.Label4.Enabled = True
End Sub
Sub youwin()
    Form1.Timer2.Enabled = False
    overflag = True
    playflag = False
    Form1.Picture1.PaintPicture Form2.Picture5(1).Picture, 140, 220, 360, 40, , , , , vbSrcCopy
    passn = passn + 1
    If passn = 9 Then passn = 8    '增加难度
    Form1.Label4.Visible = True
    Form1.Label4.Enabled = True
    Form1.Label4.Caption = "进入下一关"
End Sub
Sub pass(ByVal n As Integer)
    Select Case n
        Case 1
            Form1.Label3.Caption = "1"
            Form1.Timer2.Interval = 2500
            helpn = 10
        Case 2
            Form1.Label3.Caption = "2"
            Form1.Timer2.Interval = 2250
            helpn = 9
        Case 3
            Form1.Label3.Caption = "3"
            Form1.Timer2.Interval = 2000
            helpn = 8
        Case 4
            Form1.Label3.Caption = "4"
            Form1.Timer2.Interval = 1750
            helpn = 7
        Case 5
            Form1.Label3.Caption = "5"
            Form1.Timer2.Interval = 1500
            helpn = 6
        Case 6
            Form1.Label3.Caption = "6"
            Form1.Timer2.Interval = 1250
            helpn = 5
        Case 7
            Form1.Label3.Caption = "7"
            Form1.Timer2.Interval = 1000
            helpn = 5
        Case 8
            Form1.Timer2.Interval = 750
            Form1.Label3.Caption = "8"
            helpn = 5
    End Select
End Sub