وحید این لینک برنامه ی http://sourceproject.blogfa.com/post-15.aspx

http://prozhe.blogfa.com/post-8.aspx

این هم

Option Explicit
Dim pos(16) As String
Public gametime As Long
Private Type userRecord
 name As String * 20
 score As String * 25
End Type
Private Const SND_APPLICATION = &H80         '  look for application specific association
Private Const SND_ALIAS = &H10000     '  name is a WIN.INI [sounds] entry
Private Const SND_ALIAS_ID = &H110000    '  name is a WIN.INI [sounds] entry identifier
Private Const SND_ASYNC = &H1         '  play asynchronously
Private Const SND_FILENAME = &H20000     '  name is a file name
Private Const SND_LOOP = &H8         '  loop the sound until next sndPlaySound
Private Const SND_MEMORY = &H4         '  lpszSoundName points to a memory file
Private Const SND_NODEFAULT = &H2         '  silence not default, if sound not found
Private Const SND_NOSTOP = &H10        '  don't stop any currently playing sound
Private Const SND_NOWAIT = &H2000      '  don't wait if the driver is busy
Private Const SND_PURGE = &H40               '  purge non-static events for task
Private Const SND_RESOURCE = &H40004     '  name is a resource name or atom
Private Const SND_SYNC = &H0         '  play synchronously (default)
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long

Private Sub Form_Load()
Dim i As Integer

 pos(1) = "45 30"
 pos(2) = "45 645"
 pos(3) = "45 1260"
 pos(4) = "45 1875"
 pos(5) = "645 30"
 pos(6) = "645 645"
 pos(7) = "645 1260"
 pos(8) = "645 1875"
 pos(9) = "1245 30"
 pos(10) = "1245 645"
 pos(11) = "1245 1260"
 pos(12) = "1245 1875"
 pos(13) = "1845 30"
 pos(14) = "1845 645"
 pos(15) = "1845 1260"
 pos(16) = "1845 1875"
 
 For i = 1 To 15
  lblSquare(i).Tag = pos(i)
 Next i
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim direction As String
Dim recordlength As Integer
Dim score As Long
Dim highscore As userRecord
recordlength = LenB(highscore)
 
 If tmrScore.Enabled = False Then Exit Sub
 If KeyCode = 37 Then direction = "left"
 If KeyCode = 38 Then direction = "up"
 If KeyCode = 39 Then direction = "right"
 If KeyCode = 40 Then direction = "down"
 
 Call moveSquare(direction)
 
 If checkFinished = True Then
  tmrScore.Enabled = False
  Open App.Path + "\highscores\highscores.dat" For Random Access Read As #1 Len = recordlength
  Get #1, 5, highscore
  Close #1
  If gametime < formatTimeIntoSeconds(highscore.score) Then
   frmHighScore.Show vbModal
  Else
   gametime = 0
  End If
  lblComment.Caption = "Press File then New Game to start another game."
 End If
End Sub

Public Sub moveSquare(direction As String)
 Dim emptypos As Integer
 Dim x() As String
 emptypos = findEmptypos

 If direction = "left" Then
  If ((emptypos Mod 4) = 0) Then
   Exit Sub
  Else
   x = Split(pos(emptypos))
   Call swish(1, direction, findSquare(emptypos + 1), CInt(x(1)))
   lblSquare(findSquare(emptypos + 1)).Tag = pos(emptypos)
  End If
 End If
 
 If direction = "right" Then
  If ((emptypos Mod 4) = 1) Then
   Exit Sub
  Else
   x = Split(pos(emptypos))
   Call swish(1, direction, findSquare(emptypos - 1), CInt(x(1)))
   lblSquare(findSquare(emptypos - 1)).Tag = pos(emptypos)
  End If
 End If
 
 If direction = "down" Then
  If (emptypos < 5) Then
   Exit Sub
  Else
   x = Split(pos(emptypos))
   Call swish(1, direction, findSquare(emptypos - 4), CInt(x(0)))
   lblSquare(findSquare(emptypos - 4)).Tag = pos(emptypos)
  End If
 End If
 
 If direction = "up" Then
  If emptypos > 12 Then
   Exit Sub
  Else
   x = Split(pos(emptypos))
   Call swish(1, direction, findSquare(emptypos + 4), CInt(x(0)))
   lblSquare(findSquare(emptypos + 4)).Tag = pos(emptypos)
  End If
 End If
 PlaySound App.Path + "\sound\swish.wav", ByVal 0&, SND_FILENAME Or SND_ASYNC
End Sub

Public Function findEmptypos() As Integer
 Dim empt As Boolean
 Dim i, j As Integer
 
 For i = 1 To 16
  empt = True
  For j = 1 To 15
   If pos(i) = lblSquare(j).Tag Then
    empt = False
    Exit For
   End If
  Next j
  If empt = True Then
   findEmptypos = i
   Exit For
  End If
 Next i
End Function

Public Function findSquare(position As Integer) As Integer
Dim i As Integer
 For i = 1 To 15
  If pos(position) = lblSquare(i).Tag Then findSquare = i
 Next i
End Function

Public Sub newGame()
 Dim direction As Integer
 Dim i As Integer
 Dim x() As String
 
 lblComment.Caption = ""
 
 For i = 1 To 15
  x = Split(pos(i))
  lblSquare(i).Top = CInt(x(0))
  lblSquare(i).Left = CInt(x(1))
  lblSquare(i).Tag = pos(i)
 Next i
 
 lblComment.Caption = "Shuffling..."
 
 For i = 1 To 250
  direction = Int(4 * Rnd())
 
  Select Case direction
   Case 0
    moveSquare ("left")
   Case 1
    moveSquare ("up")
   Case 2
    moveSquare ("right")
   Case 3
    moveSquare ("down")
  End Select
 Next i
 
 tmrScore.Enabled = True
 lblComment.Caption = "Use the arrow keys to move the relevant block into empty space"
 gametime = 0
End Sub

Public Sub swish(delaytime As Integer, direction As String, square As Integer, destination_position As Integer)
If direction = "left" Or direction = "right" Then
 While (lblSquare(square).Left <> destination_position)
  Select Case direction
   Case "left"
    lblSquare(square).Left = lblSquare(square).Left - 1
   Case "right"
    lblSquare(square).Left = lblSquare(square).Left + 1
  End Select
 Wend
End If
If direction = "up" Or direction = "down" Then
 While (lblSquare(square).Top <> destination_position)
  Select Case direction
   Case "up"
    lblSquare(square).Top = lblSquare(square).Top - 1
   Case "down"
    lblSquare(square).Top = lblSquare(square).Top + 1
  End Select
 Wend
End If
End Sub

Private Sub mnuExit_Click()
 End
End Sub

Private Sub mnuHighScores_Click()
 frmHighScore.Show vbModal
End Sub

Private Sub mnuNewgame_Click()
 Call newGame
End Sub

Private Sub mnuOverview_Click()
 MsgBox "The whole point to this game is to get the blocks ordered from left to right by moving the blocks into empty space using all four of your arrow keys. The blocks should look the way that you see them before you press File and New game. When you do this the blocks are shuffled randomly. Enjoy!"
End Sub

Private Sub tmrScore_Timer()
 gametime = gametime + 1
 lblTime.Caption = formatSecondsIntoTime(gametime)
End Sub

Public Function formatSecondsIntoTime(game_time_seconds As Long) As String
 Dim hrs, min, sec As Long
 Dim result As String
 hrs = -1
 min = -1
 sec = -1
 
 sec = game_time_seconds
 If sec >= 60 Then
  min = game_time_seconds \ 60
  sec = game_time_seconds Mod 60
 End If
 
 If min >= 60 Then
  hrs = min \ 60
  min = min Mod 60
 End If
 
 result = Trim(Str(sec)) + " sec"
 If min <> -1 Then result = Trim(Str(min)) + " min " + result
 If hrs <> -1 Then result = Trim(Str(hrs)) + " hrs " + result
 formatSecondsIntoTime = result
End Function

Public Function formatTimeIntoSeconds(game_time_string As String) As Long
 Dim x() As String
 Dim i, result As Long
 
 x = Split(game_time_string)
 For i = UBound(x) To LBound(x) Step -1
  If x(i) = "sec" Then result = result + CLng(x(i - 1))
  If x(i) = "min" Then result = result + CLng(x(i - 1)) * 60
  If x(i) = "hrs" Then result = result + CLng(x(i - 1)) * 3600
 Next i
 formatTimeIntoSeconds = result
End Function

Public Function checkFinished() As Boolean
 Dim i As Integer
  checkFinished = True
  For i = 1 To 15
   If pos(i) <> lblSquare(i).Tag Then
    checkFinished = False
    Exit For
   End If
  Next i
End Function

بهم زنگ بزن نتیجه رو بگو