VB实训——电脑图标版连连看 连连看VB

　　经由十去天的努力，从最初的算法，到一个一个功能的实现，都是一字一句想出去然后敲进去的。现在终究把连连看做得像个样子了，哈哈！真是功夫没有负有心人，虽然累了，但是我非常的快乐。

代码如下：

Private Sub creatgame(bmps As Long) '创建游戏

        If pics = n * (n - 4) + 1 Then pics = 1 '如果找到末尾,再从头找起.

Declare Function sndPlaySound Lib "winmm" Alias _

    "sndPlaySoundA" (ByVal lpszSoundName As String, _

    ByVal uFlags As Long) As Long

 

Public Const SND_ASYNC = &H1

Public Const SND_NODEFAULT = &H2

Public Const SND_MEMORY = &H4

        Exit For

Public Const SND_NOSTOP = &H10

Main Form中的代码：

Option Explicit

Dim first As Boolean, firsttag As String, firstclick As Integer, n As Long, unloaded As Boolean, last As Long

rc = sndPlaySound(App.Path & "\wav\helpme.wav", SND_SYNC)

Dim picdotx As Long, picdoty As Long, lenth As Long

Dim rc As String, timelast As Long, timelasts As Long, scores As Long

        Pic(c).Tag = Pic(c).Tag - tbmp * 10000

Private Sub Form_Load()

Private Sub Pic_Click(Index As Integer)

cancel.Enabled = False

helpme.Enabled = False

replacepic.Enabled = False

Me.Top = (Screen.Height - Me.Height) / 2 '定位窗口到屏幕中央.

Next

Pic(0).Visible = False

End Sub

                    If (j <> i) And linkable(Val(Mid(Pic(i).Tag, 4, 2)), Val(Mid(Pic(i).Tag, 6, 2)), Val(Mid(Pic(j).Tag, 4, 2)), Val(Mid(Pic(j).Tag, 6, 2)), i, j) Then

Private Sub changeform() '改变窗体的大小

Me.Height = (n - 4) * Pic(0).Height + 2050 - n * 15

                    If (j <> i) And linkable(Val(Mid(Pic(i).Tag, 4, 2)), Val(Mid(Pic(i).Tag, 6, 2)), Val(Mid(Pic(j).Tag, 4, 2)), Val(Mid(Pic(j).Tag, 6, 2)), i, j) Then

Me.Top = (Screen.Height - Me.Height) / 2 '定位窗口到屏幕中央.

Me.Left = (Screen.Width - Me.Width) / 2

End Sub

TimeLine.x2 = 4440

Timer.Enabled = False

Private Sub LoadBmp(bmps As Long) '减载Pic控件

 

End Sub

Dim bmp As Long, pics As Long 'bmp暗示Pic(pics)中要减载的图标,pics暗示Pic控件的Index值,也就是减载几多个Pic控件.

    first = True 'first置为True

For i = 1 To n

    For j = 1 To n - 4

            pics = pics + 1

         &nb张曼玉sp;  Load Pic(pics)

            With Pic(pics)

                .Left = .Left + i * Pic(0).Width

                .Top = .Top + j * Pic(0).Height - 1

                .Tag = 100 * i + j + 1000000 '使用Tag标识已减载Pic控件地点的行与列,例如1000101,后面四位就暗示地点的行为1列为1,前三位除了1暗示在减载图标时的bmp值.

        If last = 0 Then

        End With

 

Next

            Case 14

For i = 1 To (n * (n - 4) / 2) '随机挪用Pic控件数减1除以2个图标,然随机地减载到两个Pic控件中,以保证图标成对出现.

End Sub

    pics = Int(Rnd * n * (n - 4)) + 1 '随机死成pics,方便第一次减载LLKres.RES中标识号为100 + bmp的图标.

    Do While Pic(pics).Picture <> 0 '.Picture = 0代表控件中没有图片,如果没有为0则pics自减1,直到找到无图片的Pic控件为止.

        pics = pics + 1

Option Explicit

    Loop

Life.Caption = 5

    Pic(pics).Tag = Pic(pics).Tag + (10000 * bmp) '将Tag的十万位与万位置为bmp值,以记录减载了相同标识号的图标.

    pics = Int(Rnd * n * (n - 4)) + 1 '再次随机死成pics,方便第二次减载LLKres.RES中标识号为100 + bmp的图标.

    Do While Pic(pics).Picture <> 0

        pics = pics + 1

        If pics = n * (n - 4) + 1 Then pics = 1

    Loop

                If tlen < lenth Then lenth = tlen: x_1 = bx: y_1 = by: x_2 = bx: y_2 = y: x_3 = ax: y_3 = y: x_4 = ax: y_4 = ay

    Pic(pics).Tag = Pic(pics).Tag + (10000 * bmp)

Next

                tlen = Abs(x - bx) + Abs(by - ay) + Abs(x - ax)

helpme.Enabled = True

wav.bas Module中的代码：

Pic(0).Top = (Me.Height - (n - 4) * Pic(0).Height) / 2 + 100 - Pic(0).Height '根据n(一行最多图标数)的没有同,定位Pic(0)的初始位置,使所有减载的图标整体看起去在窗口中央.

Pic(0).Left = (Me.Width - n * Pic(0).Width) / 2 - Pic(0).Width

LoadBmp bmps

End Sub

Me.Top = (Screen.Height - Me.Height) / 2 '定位窗口到屏幕中央.

        End If

Dim i As Long

For i = 1 To n * (n - 4)

picdotx = Pic(1).Left + Pic(0).Width / 2

Next

unloaded = True

End Sub

 

Private Sub linkline() '画线并延迟清除

ForeColor = vbYellow

        Loop

picdoty = Pic(1).Top + Pic(0).Height / 2

Pic(1).Line (Pic(1).Top, Pic(1).Top)-(Pic(1).Left + Pic(1).Width, Pic(1).Left + Pic(1).Width)

 

Line (picdotx + (x_2 - 1) * Pic(0).Width, picdoty + (y_2 - 1) * Pic(0).Height)-(picdotx + (x_3 - 1) * Pic(0).Width, picdoty + (y_3 - 1) * Pic(0).Height)

Line (picdotx + (x_3 - 1) * Pic(0).Width, picdoty + (y_3 - 1) * Pic(0).Height)-(picdotx + (x_4 - 1) * Pic(0).Width, picdoty + (y_4 - 1) * Pic(0).Height)

Dim i As Long

For i = 1 To 40000000

Me.Left = (Screen.Width - Me.Width) / 2

Cls

help

                tlen = Abs(by - y) + Abs(bx - ax) + Abs(y - ay)

Dim i As Long, j As Long

 

End Sub

 

unloaded = True

If first Then '两次单击相同的图标的Pic控件去消除可以连通的图标,first标识是否已经单击第一次,first在定义之初值为False,

    Pic(Index).Picture = LoadResPicture(Mid(Pic(Index).Tag, 2, 2) * 10 + 1 + 1000, 0) '使第一次单击的图标变暗.

            If lineable(x, ay, ax, ay) Then

    first = False '如果单击了第一次,则标识first置为False(False暗示没有单击第一次).

            If Pic((x - 1) * (n - 4) + y1).Visible = True Then lineable = False: Exit Function

    '   firsttag记录第一次单击Pic控件的Tag值并截取此中的bmp值,用此去判两次单击的Pic控件中的图标是否相同. firstclick记录上一次单击的Pic控件的Index值,并奖其与此次单击的Index值进行比较.

    '   linkable用去判断两个Pic控件是否可以连通,此中7个参数分别为:ax, ay, bx, by, firstclick, Index, n. ax暗示第一次单击的Pic控件地点的列值, ay暗示行值, bx暗示第二次单击的Pic控件地点的列值, by暗示行值, firstclick暗示上一次单击的Pic控件的Index值, Index暗示此次单击的Pic控件的Index值, n暗示一行最多的图标数.

        rc = sndPlaySound(App.Path & "\wav\linkable.wav", SND_SYNC)

        Exit For

        Pic(firstclick).Visible = False

Private Sub advanced_Click()

        scores = scores + 3

        Score.Caption = scores

l2:     Next

        Exit For

Next

            Select Case n

            Case 10

                Junior_Click

            Case 12

Private Sub unloadgame() '卸载除Pic(0)的Pic控件

For y = by + 1 To n - 4 + 1 '向下搜索

                advanced_Click

            Case 16

                highest_Click

            End Select

        End If

        Do While cannotlink

            MsgBox "对没有起，再也没有能继续下去了！" + vbCrLf + "系统自动重列。", vbInformation + vbOKOnly, "提醒"

 

    Unload Pic(i)

    Else

        Pic(Index).Picture = LoadResPicture(Val(Mid(Pic(Index).Tag, 2, 2)) + 100, 0) '如果没有满足,则恢复上一次所单击的图标.

        Pic(firstclick).Picture = LoadResPicture(Val(Mid(Pic(firstclick).Tag, 2, 2)) + 100, 0) '如果没有满足,则恢复上一次所单击的图标.

        rc = sndPlaySound(App.Path & "\wav\cannotlink.wav", SND_SYNC)

    End If

Else

Me.Width = n * Pic(0).Width + 1200 - n * 15

    Pic(Index).Picture = LoadResPicture(Mid(Pic(Index).Tag, 2, 2) * 10 + 1 + 1000, 0) '使第一次单击的图标变暗.

    firsttag = Mid(Pic(Index).Tag, 2, 2) '截取此次单击的Pic控件Tag中的保留的bmp值.

        Exit For

    rc = sndPlaySound(App.Path & "\wav\firstclick.wav", SND_SYNC)

End If

End Sub

 

timelasts = timelasts - 1

For y = by - 1 To 0 Step -1 '向上搜索

Pic(Index).Visible = False

Dim x As Long, y As Long

For x = bx + 1 To n + 1 '向右搜索

    If lineable(bx, by, x, by) Then '测试b点(第二次单击的Pic控件地点的x(bx)和y(by))与右移n位的b'点(右移的第二次单击的Pic控件地点的x(x)和y(by)是否可以连直线.

    Pic(pics).Picture = LoadResPicture(100 + bmp, 0) '减载图标.

        'lineable(x, by, x, ay) 测试b'点与a'点(右移n位的b'点的x与第一次单击的a点的ay组成的a'点[x(x),y(ay)])是否可以连直线.

        'lineable(x, ay, ax, ay) 测试a'点a[x(ax),y(ay)]是否可以连直线,如果这这四点之间可以毗邻三条直线,那么就使linkable = True.

    Else

        Exit For '如果b点与b'点没有能连通,则放弃向右搜索.

    End If

Next

For x = bx - 1 To 0 Step -1 '向左搜索

Lever.Caption = "I"

        If lineable(x, by, x, ay) Then If lineable(x, ay, ax, ay) Then linkable = True: Exit For

    Else

    firstclick = Index '保留所单击Pic控件的Index值.

    End If

Life.Caption = 4

    End If

    If lineable(bx, by, bx, y) Then

        If lineable(bx, y, ax, y) Then If lineable(ax, y, ax, ay) Then linkable = True: Exit For

    Else

        If lenth <> 1 Then linkline

    End If

Next

Pic(firstclick).Visible = False '在判断之前,将两次单击的Pic控件的Visible设置为False,否则,在判断时,会把它当作障碍.

    If lineable(bx, by, bx, y) Then

        If lineable(bx, y, ax, y) Then If lineable(ax, y, ax, ay) Then linkable = True: Exit For

    Else

        Pic(i).Tag = Pic(i).Tag + tbmp * 10000

    End If

About.Show

Pic(firstclick).Visible = True

n = 12

End Function

 

Life.Caption = 2

        Next

            End If

Dim tlen As Long

tlen = 0: lenth = 100

unloaded = False

For x = bx + 1 To n + 1 '向右搜索

        If lineable(x, by, x, ay) Then

    Timer.Enabled = True

                lenth = Abs(x - bx) + Abs(by - ay) + Abs(x - ax)

                x_1 = bx: y_1 = by: x_2 = x: y_2 = by: x_3 = x: y_3 = ay: x_4 = ax: y_4 = ay

                linelenth = True: Exit For

Pic(Index).Visible = False

                middle_Click

        'lineable(x, by, x, ay) 测试b'点与a'点(右移n位的b'点的x与第一次单击的a点的ay组成的a'点[x(x),y(ay)])是否可以连直线.

        Pic(c).Picture = LoadResPicture(Val(Mid(Pic(i).Tag, 2, 2)) + 100, 0)

        If lineable(bx, y, ax, y) Then

        Exit For '如果b点与b'点没有能连通,则放弃向右搜索.

Dim x_1 As Long, x_2 As Long, x_3 As Long, x_4 As Long, y_1 As Long, y_2 As Long, y_3 As Long, y_4 As Long

Next

    If lineable(bx, by, bx, y) Then

    If lineable(bx, by, x, by) Then

        If lineable(x, by, x, ay) Then

            If lineable(x, ay, ax, ay) Then

Private Sub abouts_Click()

                If tlen < lenth Then lenth = tlen: x_1 = bx: y_1 = by: x_2 = x: y_2 = by: x_3 = x: y_3 = ay: x_4 = ax: y_4 = ay

                linelenth = True: Exit For

    End If

changeform

    Else

        Exit For

Next

Next

            If Pic(j).Visible = True Then

    If lineable(bx, by, bx, y) Then

    Else

Pic(Index).Visible = True '恢复两次点击的Pic控件的显示.

 

                If tlen < lenth Then lenth = tlen: x_1 = bx: y_1 = by: x_2 = bx: y_2 = y: x_3 = ax: y_3 = y: x_4 = ax: y_4 = ay

                linelenth = True: Exit For

            End If

        End If

    Else

        Exit For

    End If

    End If

For y = by - 1 To 0 Step -1 '向上搜索

For x = bx - 1 To 0 Step -1 '向左搜索

        If lineable(bx, y, ax, y) Then

            If lineable(ax, y, ax, ay) Then

                tlen = Abs(by - y) + Abs(bx - ax) + Abs(y - ay)

    Pic(pics).Picture = LoadResPicture(100 + bmp, 0)

                linelenth = True: Exit For

            End If

        End If

    Else

                .Visible = True

    End If

timelasts = timelast

Pic(firstclick).Visible = True

Pic(Index).Visible = True '恢复两次点击的Pic控件的显示.

End Function

Line (picdotx + (x_1 - 1) * Pic(0).Width, picdoty + (y_1 - 1) * Pic(0).Height)-(picdotx + (x_2 - 1) * Pic(0).Width, picdoty + (y_2 - 1) * Pic(0).Height)

Next

Dim min As Long, max As Long, x As Long, y As Long

If x1 = x2 Then '两点在同一列

    If y1 > y2 Then min = y2: max = y1 Else min = y1: max = y2 'min记录y1,y2中较小的值,max记录y1,y2中较大的值.

        For y = min To max '从小值循环到大值.

            If y = 0 Or y = n - 4 + 1 Or x1 = 0 Or x1 = n + 1 Then GoTo l1

End Sub

            If Pic((x1 - 1) * (n - 4) + y).Visible = True Then lineable = False: Exit Function

            '如果此中一点的图标没有被消除,则暗示连没有通,所以使lineable = False,然后退出此函数.

l1:     Next

Else '否则两点在同一行

    If x1 > x2 Then min = x2: max = x1 Else min = x1: max = x2

        For x = min To max

            If x = 0 Or x = n + 1 Or y1 = 0 Or y1 = n - 4 + 1 Then GoTo l2

    If (Val(firsttag) = Val(Mid(Pic(Index).Tag, 2, 2))) And (Index <> firstclick) And linelenth(Val(Mid(Pic(firstclick).Tag, 4, 2)), Val(Mid(Pic(firstclick).Tag, 6, 2)), Val(Mid(Pic(Index).Tag, 4, 2)), Val(Mid(Pic(Index).Tag, 6, 2)), firstclick, Index) Then

        last = last - 2

End If

lineable = True

End Function

 

Function help() As Boolean '提醒

Dim i As Long, j As Long

MainPic.Visible = True

    If Pic(i).Visible = True Then

        For j = 1 To n * (n - 4)

            If Pic(j).Visible = True Then

                If Val(Mid(Pic(i).Tag, 2, 2)) = Val(Mid(Pic(j).Tag, 2, 2)) Then

Private Sub Pause_Click()

                        helpme = True

                        Pic(j).Picture = LoadResPicture(Mid(Pic(j).Tag, 2, 2) * 10 + 1 + 1000, 0)

Score.Caption = 0

                        Exit Function

                    End If

                End If

            End If

        Next

    End If

replace

End Function

 

Function cannotlink() As Boolean '判断是否要重排

Dim i As Long, j As Long

For i = 1 To n * (n - 4)

    If Pic(i).Visible = True Then

        For j = 1 To n * (n - 4)

For y = by + 1 To n - 4 + 1 '向下搜索

                If Val(Mid(Pic(i).Tag, 2, 2)) = Val(Mid(Pic(j).Tag, 2, 2)) Then

 

                        cannotlink = False

                        Exit Function

        Pic(Index).Visible = False '如果三个条件同时满足,则消除这两个图标.

                End If

            End If

Pic(firstclick).Visible = False '在判断之前,将两次单击的Pic控件的Visible设置为False,否则,在判断时,会把它当作障碍.

Function lineable(x1, y1, x2, y2) As Boolean '测试两点直接是否可以无障碍连直线.

 

cannotlink = True

End Function

 

Function replace() '重列图标

Dim c As Long, tbmp As Long, i As Long

Randomize

For i = 1 To Pic.UBound

    If Pic(i).Visible = True Then

If unloaded Then Else unloadgame

        Do While Pic(c).Visible = False

            c = c + 1

            If c = Pic.UBound + 1 Then c = 1

        Loop

        Pic(i).Picture = LoadResPicture(Val(Mid(Pic(c).Tag, 2, 2)) + 100, 0)

        'lineable(x, ay, ax, ay) 测试a'点a[x(ax),y(ay)]是否可以连直线,如果这这四点之间可以毗邻三条直线,那么就使linelenth = True.

        tbmp = Val(Mid(Pic(c).Tag, 2, 2))

 

        Pic(c).Tag = Pic(c).Tag + Val(Mid(Pic(i).Tag, 2, 2)) * 10000

        Pic(i).Tag = Pic(i).Tag - Val(Mid(Pic(i).Tag, 2, 2)) * 10000

Public Const SND_LOOP = &H8

    End If

Next

rc = sndPlaySound(App.Path & "\wav\replacepic.wav", SND_SYNC)

End Function

Helpnums.Caption = 5

'下面是各菜单的单击事件

cancel.Enabled = True

    If lineable(bx, by, x, by) Then

 

Lever.Caption = "II"

Score.Caption = 0

MainPic.Visible = False

helpme.Enabled = True

replacepic.Enabled = True

If unloaded Then Else unloadgame

Dim bmps As Long

timelast = 90

n = 10

        End If

bmps = 24

creatgame bmps

cancel.Enabled = True

unloaded = False

last = n * (n - 4)

            '如果y和x1已经到了图标阵列外(也就是行小于零或行小于n-2+1,或者是列小于零或行小于n+1),那么就GoTo l1进行下一次判断,因为阵列外没有用判断是否有障碍物.

Public Const SND_SYNC = &H0

Private Sub middle_Click()

Timer.Enabled = False

Life.Caption = 3

End Sub

Score.Caption = 0

MainPic.Visible = False

helpme.Enabled = True

Next

If unloaded Then Else unloadgame

Dim bmps As Long

timelast = 180

Score.Caption = 0

changeform

bmps = 28

Me.Width = 10240

cancel.Enabled = True

            replace

last = n * (n - 4)

End Sub

 

                    End If

Lever.Caption = "III"

replacepic.Enabled = True

Next

                        Pic(i).Picture = LoadResPicture(Mid(Pic(i).Tag, 2, 2) * 10 + 1 + 1000, 0)

MainPic.Visible = False

helpme.Enabled = True

replacepic.Enabled = True

If unloaded Then Else unloadgame

Dim bmps As Long

timelast = 360

n = 14

changeform

bmps = 32

creatgame bmps

Helpnums.Caption = 8

unloaded = False

last = n * (n - 4)

End Sub

cancel.Enabled = False

Private Sub highest_Click()

Lever.Caption = "IV"

        If lineable(x, by, x, ay) Then If lineable(x, ay, ax, ay) Then linkable = True: Exit For

Helpnums.Caption = 10

            If lineable(ax, y, ax, ay) Then

MainPic.Visible = False

Function linelenth(ax, ay, bx, by, firstclick, Index) As Boolean '判断两个Pic控件是否可以连通.

replacepic.Enabled = True

        c = Int(Rnd * Pic.UBound) + 1

Dim bmps As Long

timelast = 720

n = 16

changeform

bmps = 36

creatgame bmps

Private Sub Junior_Click()

Dim x As Long, y As Long

Helpnums.Caption = Helpnums.Caption - 1

End Sub

    Next

Private Sub helpme_Click()

If Helpnums.Caption = 0 Then Exit Sub

last = n * (n - 4)

End Sub

Randomize

    bmp = Int(Rnd * bmps) '随机死成bmp,使之减100后对应LLKres.RES中位图的标识号,去减载LLKres.RES中的相应位图.

 

Private Sub cancel_Click()

For i = 1 To n * (n - 4)

helpme.Enabled = False

replacepic.Enabled = False

unloadgame

 

Me.Height = 8000

creatgame bmps

 

Me.Left = (Screen.Width - Me.Width) / 2

Next

            MsgBox "恭喜你，过关了！", vbInformation + vbOKOnly, "过关"

Private Sub replacepic_Click()

If Life.Caption = 0 Then Exit Sub

Life.Caption = Life.Caption - 1

            End If

Helpnums.Caption = 6

unloaded = False

Private Sub exitgame_Click()

Unload Me

End Sub

 

End Sub

cancel.Enabled = True

End Sub

 

Private Sub Timer_Timer()

Function linkable(ax, ay, bx, by, firstclick, Index) As Boolean '判断两个Pic控件是否可以连通.

If timelasts = 0 Then MsgBox "对没有起，时间已到！", vbCritical + vbOKOnly, "时间到": cancel_Click

TimeLine.x2 = 1785 + 2665 * (timelasts / timelast)

End Sub

 

    If lineable(bx, by, x, by) Then '测试b点(第二次单击的Pic控件地点的x(bx)和y(by))与右移n位的b'点(右移的第二次单击的Pic控件地点的x(x)和y(by)是否可以连直线.