nokian9612
یک شنبه 03 دی 1391, 18:09 عصر
برنامه ام خطای Runtime error 9 میده لطفاً راهنمایی کنید اینم کد کل برنامه، لطفا جایی که باید تغییر بدم بهم بگید.
Option Explicit
Dim pos(9) 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) = "645 30"
pos(5) = "645 645"
pos(6) = "645 1260"
pos(7) = "1245 30"
pos(8) = "1245 645"
pos(9) = "1245 1260"
For i = 1 To 8
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 9
empt = True
For j = 1 To 8
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 8
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 8
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 8
If pos(i) <> lblSquare(i).Tag Then
checkFinished = False
Exit For
End If
Next i
End Function
Option Explicit
Dim pos(9) 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) = "645 30"
pos(5) = "645 645"
pos(6) = "645 1260"
pos(7) = "1245 30"
pos(8) = "1245 645"
pos(9) = "1245 1260"
For i = 1 To 8
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 9
empt = True
For j = 1 To 8
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 8
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 8
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 8
If pos(i) <> lblSquare(i).Tag Then
checkFinished = False
Exit For
End If
Next i
End Function