Пятнашки - двигать на несколько костей

'проверка возможности обмена
If Not ((Abs(cx - ex) = 1) And (cy - ey = 0) Or _
           (Abs(cy - ey) = 1) And (cx - ex = 0)) Then Exit Sub

    'перемещение 1 фишки
    If Cheng1 = True Then
        'обмен: перемещение 1 фишки из (x, y) в (ex, ey)
        pole(ey, ex) = pole(cy, cx)
        pole(cy, cx) = 0
        ex = cx
        ey = cy
 
        'перемещение 2 фишек
    ElseIf Cheng2 = True Then
 
        'перемещение 3 фишек
    ElseIf Cheng3 = True Then
 
    Else
        'звук сигнала, когда обмен не возможен
        Beep
        Exit Sub
    End If

Option Explicit
 
'размер поля - 4х4
Const Lpole = 4
 
'размер ячейки - 50x50
Const Lcells = 50
 
'правильное расположение фишек
Dim stp(1 To Lpole, 1 To Lpole) As Byte
'игровое поле
Dim pole(1 To Lpole, 1 To Lpole) As Byte
'направление перемещения, относительно пустой фишки
Dim d As Byte
'координаты пустой клетки
Dim ex As Byte: Dim ey As Byte
'счетчик циклов
Dim i As Byte: Dim j As Byte
'X,Y - координаты вывода текста в клетке
Dim X As Byte: Dim Y As Byte
'
 
'инициализация формы
Private Sub Form_Initialize()
 
    Form1.Width = (Form1.Width - Form1.ScaleWidth) + (Lcells * Lpole) * Screen.TwipsPerPixelX
    Form1.Height = (Form1.Height - Form1.ScaleHeight) + (Lcells * Lpole) * Screen.TwipsPerPixelY
    Form1.Font.Size = 10
    Form1.ScaleMode = 3
 
    Randomize
    Call newGame
 
End Sub
 
'новая игра
Sub newGame()
 
    For i = 1 To Lpole
        For j = 1 To Lpole
            'правильное расположение фишек
            stp(i, j) = (i - 1) * Lpole + j
            pole(i, j) = stp(i, j)
        Next j
    Next i
 
    stp(Lpole, Lpole) = 0
 
    'перемешивание фишек
    Call mixer
    'вывод поля
    Call showPole
 
End Sub
 
'вывод игрового поля
Sub showPole()
 
'очистка поля от предыдущего хода
    Form1.Cls
 
    'сетка: вертикальные линии
    For i = 1 To (Lpole - 1)
        Line (i * Lcells, 0)-(i * Lcells, Lcells * Lpole)
    Next i
 
    'сетка: горизонтальные линии
    For i = 1 To (Lpole - 1)
        Line (0, i * Lcells)-(Lcells * Lpole, i * Lcells)
    Next i
 
    'содержимое клеток (цифры фишек)
    For i = 1 To Lpole
        Y = (i - 1) * Lcells + 18
        For j = 1 To Lpole
            X = (j - 1) * Lcells + 18
            Select Case pole(i, j)
            Case 0:
            Case 1 To 9:
                CurrentX = X
                CurrentY = Y
                Print " " + Format(pole(i, j))
            Case 10 To 15:
                CurrentX = X
                CurrentY = Y
                Print Format(pole(i, j))
            End Select
        Next j
    Next i
 
End Sub
 
'функция проверяет, расположены ли фишки в нужном порядке
Function Finish() As Boolean
 
'координаты фишки
    Dim row As Byte: Dim col As Byte
    row = 1: col = 1
 
    'пусть фишки расположены в нужном порядке
    Finish = True
 
    For i = 1 To (Lpole * Lpole - 1)
        If pole(row, col) <> i Then
            Finish = False
            Exit Function
        End If
 
        'к следующей клетке
        If col < Lpole Then
            col = col + 1
        Else
            col = 1
            row = row + 1
        End If
    Next i
 
End Function
 
'процедура '"перемешивает" фишки
Sub mixer()
 
'координаты пустой фишки
    Dim x1 As Byte: Dim y1 As Byte
    x1 = Lpole: y1 = Lpole
 
    'координаты фишки, перемещаемой на место пустой
    Dim x2 As Byte: Dim y2 As Byte
 
    For i = 1 To Lpole * Lpole * 10
        Do
            x2 = x1
            y2 = y1
            'предполагается, что поле квадратное
            d = Int((Rnd * Lpole) + 1)
            Select Case d
            Case 1: x2 = x2 + 1
            Case 2: x2 = x2 - 1
            Case 3: y2 = y2 + 1
            Case 4: y2 = y2 - 1
            End Select
 
        Loop Until (x2 >= 1) And (x2 <= Lpole) And _
             (y2 >= 1) And (y2 <= Lpole)
 
        pole(y1, x1) = pole(y2, x2)
        pole(y2, x2) = 0
 
        x1 = x2
        y1 = y2
    Next i
 
    'запоминание координаты пустой клетки
    ex = x1: ey = y1
 
End Sub
 
'процедура "перемещает" фишку в соседнюю пустую клетку, если она есть
Sub fMove(cx, cy)
 
'номер клетки, по которой кликнули мышью
    Dim NumberClic As Byte
 
    'cx, cy - клетка, в которой игрок сделал щелчок
    If cx = 1 And cy = 1 Then
        NumberClic = 1
    ElseIf cx = 2 And cy = 1 Then
        NumberClic = 2
    ElseIf cx = 3 And cy = 1 Then
        NumberClic = 3
    ElseIf cx = 4 And cy = 1 Then
        NumberClic = 4
    ElseIf cx = 1 And cy = 2 Then
        NumberClic = 5
    ElseIf cx = 2 And cy = 2 Then
        NumberClic = 6
    ElseIf cx = 3 And cy = 2 Then
        NumberClic = 7
    ElseIf cx = 4 And cy = 2 Then
        NumberClic = 8
    ElseIf cx = 1 And cy = 3 Then
        NumberClic = 9
    ElseIf cx = 2 And cy = 3 Then
        NumberClic = 10
    ElseIf cx = 3 And cy = 3 Then
        NumberClic = 11
    ElseIf cx = 4 And cy = 3 Then
        NumberClic = 12
    ElseIf cx = 1 And cy = 4 Then
        NumberClic = 13
    ElseIf cx = 2 And cy = 4 Then
        NumberClic = 14
    ElseIf cx = 3 And cy = 4 Then
        NumberClic = 15
    ElseIf cx = 4 And cy = 4 Then
        NumberClic = 16
    End If
 
    'номер пустой клетки
    Dim NumberNull As Byte
 
    'cx, cy - пустая клетка
    If ex = 1 And ey = 1 Then
        NumberNull = 1
    ElseIf ex = 2 And ey = 1 Then
        NumberNull = 2
    ElseIf ex = 3 And ey = 1 Then
        NumberNull = 3
    ElseIf ex = 4 And ey = 1 Then
        NumberNull = 4
    ElseIf ex = 1 And ey = 2 Then
        NumberNull = 5
    ElseIf ex = 2 And ey = 2 Then
        NumberNull = 6
    ElseIf ex = 3 And ey = 2 Then
        NumberNull = 7
    ElseIf ex = 4 And ey = 2 Then
        NumberNull = 8
    ElseIf ex = 1 And ey = 3 Then
        NumberNull = 9
    ElseIf ex = 2 And ey = 3 Then
        NumberNull = 10
    ElseIf ex = 3 And ey = 3 Then
        NumberNull = 11
    ElseIf ex = 4 And ey = 3 Then
        NumberNull = 12
    ElseIf ex = 1 And ey = 4 Then
        NumberNull = 13
    ElseIf ex = 2 And ey = 4 Then
        NumberNull = 14
    ElseIf ex = 3 And ey = 4 Then
        NumberNull = 15
    ElseIf ex = 4 And ey = 4 Then
        NumberNull = 16
    End If
 
    'перемещение 1 фишки   перемещение 2 фишек    перемещение 3 фишек
    Dim Cheng1 As Boolean: Dim Cheng2 As Boolean: Dim Cheng3 As Boolean
    'инициализация переменных
    Cheng1 = False: Cheng2 = False: Cheng3 = False
 
    If NumberClic = 1 Then
        If NumberNull = 2 Or NumberNull = 5 Then
            Cheng1 = True
        ElseIf NumberNull = 3 Or NumberNull = 9 Then
            Cheng2 = True
        ElseIf NumberNull = 4 Or NumberNull = 13 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 2 Then
        If NumberNull = 1 Or NumberNull = 3 Or NumberNull = 6 Then
            Cheng1 = True
        ElseIf NumberNull = 4 Or NumberNull = 10 Then
            Cheng2 = True
        ElseIf NumberNull = 14 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 3 Then
        If NumberNull = 2 Or NumberNull = 4 Or NumberNull = 7 Then
            Cheng1 = True
        ElseIf NumberNull = 1 Or NumberNull = 11 Then
            Cheng2 = True
        ElseIf NumberNull = 15 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 4 Then
        If NumberNull = 3 Or NumberNull = 8 Then
            Cheng1 = True
        ElseIf NumberNull = 2 Or NumberNull = 12 Then
            Cheng2 = True
        ElseIf NumberNull = 1 Or NumberNull = 16 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 5 Then
        If NumberNull = 1 Or NumberNull = 6 Or NumberNull = 9 Then
            Cheng1 = True
        ElseIf NumberNull = 7 Or NumberNull = 13 Then
            Cheng2 = True
        ElseIf NumberNull = 8 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 6 Then
        If NumberNull = 2 Or NumberNull = 5 Or NumberNull = 7 Or NumberNull = 10 Then
            Cheng1 = True
        ElseIf NumberNull = 8 Or NumberNull = 14 Then
            Cheng2 = True
        End If
 
    ElseIf NumberClic = 7 Then
        If NumberNull = 3 Or NumberNull = 6 Or NumberNull = 8 Or NumberNull = 11 Then
            Cheng1 = True
        ElseIf NumberNull = 5 Or NumberNull = 15 Then
            Cheng2 = True
        End If
 
    ElseIf NumberClic = 8 Then
        If NumberNull = 4 Or NumberNull = 7 Or NumberNull = 12 Then
            Cheng1 = True
        ElseIf NumberNull = 6 Or NumberNull = 16 Then
            Cheng2 = True
        ElseIf NumberNull = 5 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 9 Then
        If NumberNull = 5 Or NumberNull = 10 Or NumberNull = 13 Then
            Cheng1 = True
        ElseIf NumberNull = 1 Or NumberNull = 11 Then
            Cheng2 = True
        ElseIf NumberNull = 12 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 10 Then
        If NumberNull = 6 Or NumberNull = 9 Or NumberNull = 11 Or NumberNull = 14 Then
            Cheng1 = True
        ElseIf NumberNull = 2 Or NumberNull = 12 Then
            Cheng2 = True
        End If
 
    ElseIf NumberClic = 11 Then
        If NumberNull = 7 Or NumberNull = 10 Or NumberNull = 12 Or NumberNull = 15 Then
            Cheng1 = True
        ElseIf NumberNull = 3 Or NumberNull = 9 Then
            Cheng2 = True
        End If
 
    ElseIf NumberClic = 12 Then
        If NumberNull = 8 Or NumberNull = 11 Or NumberNull = 16 Then
            Cheng1 = True
        ElseIf NumberNull = 4 Or NumberNull = 10 Then
            Cheng2 = True
        ElseIf NumberNull = 9 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 13 Then
        If NumberNull = 9 Or NumberNull = 14 Then
            Cheng1 = True
        ElseIf NumberNull = 5 Or NumberNull = 15 Then
            Cheng2 = True
        ElseIf NumberNull = 1 Or NumberNull = 16 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 14 Then
        If NumberNull = 10 Or NumberNull = 13 Or NumberNull = 15 Then
            Cheng1 = True
        ElseIf NumberNull = 6 Or NumberNull = 16 Then
            Cheng2 = True
        ElseIf NumberNull = 2 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 15 Then
        If NumberNull = 11 Or NumberNull = 14 Or NumberNull = 16 Then
            Cheng1 = True
        ElseIf NumberNull = 7 Or NumberNull = 13 Then
            Cheng2 = True
        ElseIf NumberNull = 3 Then
            Cheng3 = True
        End If
 
    ElseIf NumberClic = 16 Then
        If NumberNull = 15 Or NumberNull = 12 Then
            Cheng1 = True
        ElseIf NumberNull = 8 Or NumberNull = 14 Then
            Cheng2 = True
        ElseIf NumberNull = 4 Or NumberNull = 13 Then
            Cheng3 = True
        End If
    End If
 
    'перемещение 1 фишки
    If Cheng1 = True Then
        'обмен: перемещение 1 фишки из (x, y) в (ex, ey)
        pole(ey, ex) = pole(cy, cx)
        pole(cy, cx) = 0
        ex = cx
        ey = cy
 
        'перемещение 2 фишек
    ElseIf Cheng2 = True Then
        pole(ey, ex) = pole(cy, cx)
        pole(cy, cx) = 0
        ex = cx
        ey = cy
 
        'перемещение 3 фишек
    ElseIf Cheng3 = True Then
        pole(ey, ex) = pole(cy, cx)
        pole(cy, cx) = 0
        ex = cx
        ey = cy
 
    Else
        'звук сигнала, когда обмен не возможен
        Beep
        Exit Sub
    End If
 
    'вывод поля
    Call showPole
 
    If Finish = True Then
        If MsgBox( _
           "Цель достигнута!" + vbCrLf + _
           "Еше раз?", vbYesNo, "Игра 15") = vbYes Then
            'новая игра
            Call newGame
        Else
            'завершение работы программы
            Unload Form1
        End If
    End If
 
End Sub
 
'щелчок мышки на форме
Private Sub Form_MouseDown( _
        Button As Integer, _
        Shift As Integer, _
      X As Single, _
      Y As Single)
'X, Y - координаты щелчка
 
'01 02 03 04
'05 06 07 08
'09 10 11 12
'13 14 15 16
 
'1 ряд
'01 x 000-050  y 000-050
'02 x 050-100  y 000-050
'03 x 100-150  y 000-050
'04 x 150-200  y 000-050
 
'2 ряд
'05 x 000-050 y 050-100
'06 x 050-100 y 050-100
'07 x 100-150 y 050-100
'08 x 150-200 y 050-100
 
'3 ряд
'09 x 000-050 y 100-150
'10 x 050-100 y 100-150
'11 x 100-150 y 100-150
'12 x 150-200 y 100-150
 
'4 ряд
'13 x 000-050 y 150-200
'14 x 050-100 y 150-200
'15 x 100-150 y 150-200
'16 x 150-200 y 150-200
 
    If X Mod 50 = 0 Or Y Mod 50 = 0 Then
        MsgBox$ "Нажмите курсором мыши в центр перемещаемой кости"
        Exit Sub
    End If
 
    'координаты клетки
    Dim cx As Byte: Dim cy As Byte
 
    'преобразуем щелчок в координаты клетки
    cx = Int(X / Lcells) + 1: cy = Int(Y / Lcells) + 1
 
    Call fMove(cx, cy)
 
End Sub

Const CH = 50, CW = 50              ' размер клетки - 50x50