经由十去天的努力,从最初的算法,到一个一个功能的实现,都是一字一句想出去然后敲进去的。现在终究把连连看做得像个样子了,哈哈!真是功夫没有负有心人,虽然累了,但是我非常的快乐。
代码如下:
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)是否可以连直线.