Option Explicit
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260
Private Const MSHCTX_INPROC As Long = &H3&
Private Const MSHLFLAGS_NORMAL As Long = &H0&
Private Type OBJREF
    Signature As String * 4         'Signature MEOW.
    Flag As Long
    IID(15) As Byte                 'Interface infrntifier.
    Flags As Long
    RefCount As Long
    OXID(7) As Byte
    OID(7) As Byte
    IPID(7) As Integer
End Type
Private Type GUID
    Data1       As Long
    Data2       As Integer
    Data3       As Integer
    Data4(7)    As Byte
End Type
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef ppstm As Long) As Long
Private Declare Function GetHGlobalFromStream Lib "ole32.dll" (ByVal pStm As Long, ByRef phglobal As Long) As Long
Private Declare Function CoMarshalInterface Lib "ole32.dll" (ByVal pStm As Long, ByRef riid As GUID, _
    ByVal pUnk As Long, ByVal dwDestContext As Long, ByVal pvDestContext As Long, ByVal mshlflags As Long) As Long
Private Declare Function UuidFromString Lib "Rpcrt4.dll" Alias "UuidFromStringA" (ByVal StringUuid As String, ByRef Uuid As GUID) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32.dll" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, ByRef lppe As PROCESSENTRY32) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Sub Main()
    Dim lngPID As Long, iCOMObjectInterface As Object
    lngPID = GetServerProcessID(iCOMObjectInterface)
End Sub
Private Function GetServerProcessID( _
    ByVal pUnk As KompasAPI7.IApplication _
    ) As Long
    Dim lngRetval As Long, iStreamPtr As Long, udtGUID As GUID, lnhHMem As Long, _
        strStringUuid As String, lnhPtr As Long, udtOBJREF As OBJREF
    'Функция получает ID процесса COM сервера.
    'Создаем объект iStream.
    lngRetval = CreateStreamOnHGlobal(0&, True, iStreamPtr)
    'UUID интерфейса.
    strStringUuid = "6A2EFAF7-0000-0000-0000-2213F16AF5D7"
    'Конвертируем строку в структуру.
    lngRetval = UuidFromString(strStringUuid, udtGUID)
    'Записываем данные для маршалинга в  объект iStream.
    lngRetval = CoMarshalInterface(iStreamPtr, udtGUID, _
        ObjPtr(pUnk), MSHCTX_INPROC, 0&, MSHLFLAGS_NORMAL)
    'Получаем хэндл на данные объекта iStream.
    lngRetval = GetHGlobalFromStream(iStreamPtr, lnhHMem)
    'Получаем указатель на данные по хэнлду.
    lnhPtr = GlobalLock(lnhHMem)
    'Копируем данные в структуру.
    Call CopyMemory(udtOBJREF, ByVal lnhPtr, LenB(udtOBJREF))
    'Проверяем сигнатуру структуры и флаг, указывающий на содержимое требуемого поля c++ union.
    If (Not (udtOBJREF.Signature = "MEOW") Or (udtOBJREF.Flag <> 1)) Then
        'Ошибка получения данных маршалинга.
    Else
        'Возвращаем PID процесса COM сервера.
        GetServerProcessID = udtOBJREF.IPID(2)
    End If
    'Снимаем блокировку с буфера.
    lngRetval = GlobalUnlock(lnhHMem)
End Function

Option Explicit
'//////////////////////////////////////////////////
'// Модуль для работы с реестром                 //
'// Copyright (c) 20.01.2022 by Владислав Пешков //
'// e-mail: vladislavpeshkov@yandex.ru           //
'// Версия 3.0                                   //
'//////////////////////////////////////////////////
 
' Декларации API...
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, ByRef lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetDWORDValueEx Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, dwData As Long, Optional ByVal cbData As Long = 4) As Long
Private Declare Function RegOpenKey Lib "advapi32" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32" Alias "RegDeleteKeyW" (ByVal hKey As Long, ByVal lpSubKey As Long) As Long
Private Declare Function RegDeleteKeyEx Lib "advapi32" Alias "RegDeleteKeyExW" (ByVal hKey As Long, ByVal lpSubKey As Long, ByVal samDesired As Long, ByVal Reserved As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegEnumKeyA Lib "advapi32" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long ' for 9x
Private Declare Function RegEnumKeyW Lib "advapi32" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As Long, ByVal cbName As Long) As Long ' for NT
Private Declare Function RegEnumValueA Lib "advapi32" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' for 9x
Private Declare Function RegEnumValueW Lib "advapi32" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As Long, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' for NT
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function IsWow64Process Lib "kernel32" (ByVal hProc As Long, bWow64Process As Long) As Long
 
' Константы...
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_DWORD = 4
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const READ_CONTROL = &H20000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Private Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Private Const KEY_EXECUTE = KEY_READ
Private Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
Private Const ERROR_NONE = 0
Private Const ERROR_BADKEY = 2
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_SUCCESS = 0
Private Const KEY_WOW64_64KEY = &H100
Private Const KEY_WOW64_32KEY = &H200
 
' Типы...
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Boolean
End Type
 
' Публично объявленный енум
Public Enum RootKeys
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_DYN_DATA = &H80000006
End Enum
 
' Обновляет ключ реестра
Public Function UpdateKey(KeyRoot As RootKeys, KeyName As String, SubKeyName As String, SubKeyValue As String, Optional reg64 As Boolean) As Boolean
    Dim rc As Long                                      ' Return Code
    Dim hKey As Long                                    ' Handle To A Registry Key
    Dim hDepth As Long                                  '
    Dim lpAttr As SECURITY_ATTRIBUTES                   ' Registry Security Type
    
    lpAttr.nLength = 50                                 ' Set Security Attributes To Defaults...
    lpAttr.lpSecurityDescriptor = 0                     ' ...
    lpAttr.bInheritHandle = True                        ' ...
    
    '------------------------------------------------------------
    '- Create/Open Registry Key...
    '------------------------------------------------------------
    rc = RegCreateKeyEx(KeyRoot, KeyName, _
                        0, REG_SZ, _
                        REG_OPTION_NON_VOLATILE, IIf(reg64, KEY_ALL_ACCESS Or KEY_WOW64_64KEY, KEY_ALL_ACCESS), lpAttr, _
                        hKey, hDepth)                   ' Create/Open //KeyRoot//KeyName
    
    If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError   ' Handle Errors...
    
    '------------------------------------------------------------
    '- Create/Modify Key Value...
    '------------------------------------------------------------
    If (SubKeyValue = "") Then SubKeyValue = " "        ' A Space Is Needed For RegSetValueEx() To Work...
    
    ' Create/Modify Key Value
    rc = RegSetValueEx(hKey, SubKeyName, _
                       0, REG_SZ, _
                       SubKeyValue, LenB(StrConv(SubKeyValue, vbFromUnicode)))
                       
    If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError   ' Handle Error
    '------------------------------------------------------------
    '- Close Registry Key...
    '------------------------------------------------------------
    rc = RegCloseKey(hKey)                              ' Close Key
    
    UpdateKey = True                                    ' Return Success
    Exit Function                                       ' Exit
CreateKeyError:
    UpdateKey = False                                   ' Set Error Return Code
    rc = RegCloseKey(hKey)                              ' Attempt To Close Key
End Function
 
' Считывает данные из реестра
Public Function GetKeyValue(KeyRoot As RootKeys, KeyName As String, SubKeyRef As String, Optional reg64 As Boolean) As String
    Dim i As Long
    Dim hKey As Long ' Handle To An Open Registry Key
    Dim sKeyVal As String
    Dim lKeyValType As Long ' Data Type Of A Registry Key
    Dim bufer As String
    Dim strlen As Long
    
    If RegOpenKeyEx(KeyRoot, KeyName, 0, IIf(reg64, KEY_ALL_ACCESS Or KEY_WOW64_64KEY, KEY_ALL_ACCESS), hKey) = ERROR_SUCCESS Then
        RegQueryValueEx hKey, SubKeyRef, 0, lKeyValType, ByVal 0&, strlen
        
        If strlen > 0 Then
            bufer = Space$(strlen)
            
            If RegQueryValueEx(hKey, SubKeyRef, 0, lKeyValType, bufer, strlen) = ERROR_SUCCESS Then
                If strlen > 0 Then
                    bufer = Left$(bufer, strlen - 1)
                    
                    Select Case lKeyValType                                    ' Search Data Types...
                        Case REG_SZ, REG_EXPAND_SZ                             ' String Registry Key Data Type
                            sKeyVal = bufer                                    ' Copy String Value
                        Case REG_DWORD                                         ' Double Word Registry Key Data Type
                            For i = Len(bufer) To 1 Step -1                    ' Convert Each Bit
                                sKeyVal = sKeyVal + Hex(Asc(Mid(bufer, i, 1))) ' Build Value Char. By Char.
                            Next
                            sKeyVal = Format$("&H" + sKeyVal)                  ' Convert Double Word To String
                    End Select
                    
                    GetKeyValue = sKeyVal                                      ' Return Value
                End If
            End If
        End If
        
        RegCloseKey hKey
    End If
End Function
 
' Удаляет ключ реестра
Public Function DeleteKey(KeyRoot As RootKeys, KeyName As String, Optional reg64 As Boolean) As Boolean
    Dim rc As Long
    
    If reg64 = False Then
        rc = RegDeleteKey(KeyRoot, StrPtr(KeyName))
    Else
        If IsWow64MyProcess = True Then
            rc = RegDeleteKeyEx(KeyRoot, StrPtr(KeyName), KEY_ALL_ACCESS Or KEY_WOW64_64KEY, 0)
        Else
            Exit Function
        End If
    End If
    
    If rc = ERROR_SUCCESS Then DeleteKey = True
End Function
 
' Создание списка ключей реестра
Public Function EnumKeys(KeyRoot As RootKeys, KeyName As String, RegKeys() As String, Optional reg64 As Boolean) As Boolean
    Dim hKey, curidx As Long
    Dim bufer As String
    Dim IsWindowsNT As Boolean
    Dim strlen As Long
    
    If RegOpenKeyEx(KeyRoot, KeyName, 0, IIf(reg64, KEY_ALL_ACCESS Or KEY_WOW64_64KEY, KEY_ALL_ACCESS), hKey) = ERROR_SUCCESS Then
        ReDim RegKeys(0)
        If StrComp(Environ("OS"), "Windows_NT", vbTextCompare) = 0 Then IsWindowsNT = True
        
        Do
            bufer = String$(2048, vbNullChar)
            
            If IsWindowsNT = True Then
                If RegEnumKeyW(hKey, curidx, StrPtr(bufer), 2048) <> ERROR_SUCCESS Then Exit Do
            Else
                If RegEnumKeyA(hKey, curidx, bufer, 2048) <> ERROR_SUCCESS Then Exit Do
            End If
            
            strlen = InStr(1, bufer, vbNullChar)
            If strlen > 0 Then bufer = Left$(bufer, strlen - 1)
            
            If Len(bufer) > 0 Then
                ReDim Preserve RegKeys(curidx)
                RegKeys(curidx) = bufer
                curidx = curidx + 1
                
                If EnumKeys <> True Then EnumKeys = True
            End If
        Loop
        
        RegCloseKey hKey
    End If
End Function
 
' Создание списка параметров ключа
Public Function EnumValues(KeyRoot As RootKeys, KeyName As String, RegValues() As String, Optional reg64 As Boolean) As Boolean
    Dim hKey, curidx As Long
    Dim bufer As String
    Dim IsWindowsNT As Boolean
    Dim strlen As Long
    
    If RegOpenKeyEx(KeyRoot, KeyName, 0, IIf(reg64, KEY_ALL_ACCESS Or KEY_WOW64_64KEY, KEY_ALL_ACCESS), hKey) = ERROR_SUCCESS Then
        ReDim RegValues(0)
        If StrComp(Environ("OS"), "Windows_NT", vbTextCompare) = 0 Then IsWindowsNT = True
        
        Do
            bufer = Space$(2048)
            strlen = 2048
            
            If IsWindowsNT = True Then
                If RegEnumValueW(hKey, curidx, StrPtr(bufer), strlen, 0, ByVal 0&, ByVal 0&, ByVal 0&) <> ERROR_SUCCESS Then Exit Do
            Else
                If RegEnumValueA(hKey, curidx, bufer, strlen, 0, ByVal 0&, ByVal 0&, ByVal 0&) <> ERROR_SUCCESS Then Exit Do
            End If
            
            If strlen > 0 Then
                bufer = Left$(bufer, strlen)
                
                If Len(bufer) > 0 Then
                    ReDim Preserve RegValues(curidx)
                    RegValues(curidx) = bufer
                    curidx = curidx + 1
                    
                    If EnumValues <> True Then EnumValues = True
                End If
            End If
        Loop
        
        RegCloseKey hKey
    End If
End Function
 
' Обновляет ключ реестра параметром DWORD
Public Function SetRegDWORD(hKey As RootKeys, lpszSubKey As String, sSetValue As String, ByVal dwValue As Long, Optional reg64 As Boolean) As Boolean
    On Error GoTo ErrorRoutineErr:
    
    Dim phkResult As Long
    Dim lResult As Long
    Dim SA As SECURITY_ATTRIBUTES
    Dim Create As Long
    
    ' Note: This function will create the key or
    ' value if it doesn't exist.
    ' Open or Create the key
    RegCreateKeyEx hKey, lpszSubKey, 0, "", REG_OPTION_NON_VOLATILE, IIf(reg64, KEY_ALL_ACCESS Or KEY_WOW64_64KEY, KEY_ALL_ACCESS), SA, phkResult, Create
    lResult = RegSetDWORDValueEx(phkResult, sSetValue, 0&, REG_DWORD, dwValue, 4)
    
    ' Close the key
    RegCloseKey phkResult
    
    ' Return SetRegValue Result
    SetRegDWORD = (lResult = ERROR_SUCCESS)
    Exit Function
    
ErrorRoutineErr::
  SetRegDWORD = False
End Function
 
' Удалить любой параметр, в том числе DWORD
Public Function DeleteRegValue(hKey As RootKeys, lpszSubKey As String, sValueName As String, Optional reg64 As Boolean) As Boolean
    On Error GoTo ErrorRoutineErr:
    
    Dim phkResult As Long
    Dim lResult As Long
    Dim SA As SECURITY_ATTRIBUTES
    Dim Create As Long
    
    ' Open or Create the key
    RegCreateKeyEx hKey, lpszSubKey, 0, "", REG_OPTION_NON_VOLATILE, IIf(reg64, KEY_ALL_ACCESS Or KEY_WOW64_64KEY, KEY_ALL_ACCESS), SA, phkResult, Create
    
    lResult = RegDeleteValue(phkResult, sValueName)
    RegCloseKey phkResult
    
    ' Return obtained value
    If lResult = ERROR_SUCCESS Then
        DeleteRegValue = True
    Else
        DeleteRegValue = False
    End If
    Exit Function
    
ErrorRoutineErr::
    DeleteRegValue = False
End Function
 
' Запущен ли мой процесс в 64-битной среде
Public Function IsWow64MyProcess() As Boolean
    Dim MyProcRunIs64 As Long
    Dim handle As Long
    
    handle = LoadLibrary("kernel32")
    
    If GetProcAddress(handle, "IsWow64Process") > 0 Then
        IsWow64Process -1, MyProcRunIs64
        If MyProcRunIs64 = 1 Then IsWow64MyProcess = True
    End If
    
    FreeLibrary handle
End Function

Option Explicit
Dim k As Integer, m As Integer
Dim StrokaLoad(1024) As String, StrokaArr(1024) As String
Dim correct As String 'слово правильного ответа
Dim gnrt As Integer 'результат генерации
Dim second As Byte
Dim i As Byte, s As Byte
 
Private Sub Form_Load() '---------------------------- загрузка в массив БД
    k = 1 ' -------------------------------------------------------- переменная счетчика
   Open App.Path & "\gramotey.bzd" For Input As #1  ' ------------------- считывание из текста
    While Not EOF(1)
        Line Input #1, StrokaLoad(k)
        k = k + 1
    Wend
    Close #1 '------------  операция завершена
        k = k - 1
Примечание.Caption = "в базе данных вопросов - " & k
For m = 1 To k: StrokaArr(m) = "": Next m
End Sub
 
Private Sub mnuStart_Click()
    Call Generator
    Call OutAndTest
End Sub
 
Private Sub word_Click(Index As Integer)
    If word(Index) = correct Then
        Примечание.Caption = "Ответ правильный"
        imgImage(Index).Picture = lstImg.ListImages("yes").Picture
        Timer1.Interval = 500
        second = 10
Else
         imgImage(Index).Picture = lstImg.ListImages("no").Picture
    End If
End Sub
 
'временная задержка между вопросами
Private Sub Timer1_Timer()
    second = second - 1
'    Примечание.Caption = Str(second)
    If second = 0 Then
            Примечание.Caption = ""
            Timer1.Interval = 0
            k = k - 1
                If k = 0 Then End
            Call OutAndTest
    End If
End Sub
 
'вывод на экран и проверка на правильность
'===============================================================
Sub OutAndTest() 'разделяем позиции из строки
For i = 1 To 4: imgImage(i).Picture = LoadPicture(): Next i
word(0).Caption = k
Dim lblLine(4) As String, tmp As String
s = 1: For i = 1 To 4: lblLine(i) = "": Next i
    For i = 1 To Len(StrokaArr(k))
        tmp = Mid(StrokaArr(k), i, 1)
            If tmp = ";" Then
                s = s + 1
                i = i + 1
            Else
                lblLine(s) = lblLine(s) & tmp
            End If
    Next i
For i = 1 To 4: word(i) = "": Next i 'очищаем массив
correct = lblLine(1) 'правильный ответ в переменную correct
'перемешать линии
m = 1
Do While (m < 5) 'наше количество
    Randomize
    gnrt = Int((4 * Rnd) + 1)      'рандомное определение позиции в строке
    If word(gnrt) = "" Then      'если позиция пустая
       word(gnrt) = lblLine(m)       '  присвоить ей значение
        m = m + 1 'увеличиваем счетчик на 1
    End If
Loop 'следующая итерация цикла
End Sub
 
'генерирует строчки в массиве
'===============================================================
Sub Generator()
m = 1
Do While (m < k + 1) 'наше количество
    Randomize
    gnrt = Int((k * Rnd) + 1)      'рандомное определение номера строки
    If StrokaArr(gnrt) = "" Then      'если строка пустая
       StrokaArr(gnrt) = StrokaLoad(m)       '  присвоить ей строку
        m = m + 1 'увеличиваем счетчик на 1
    End If
Loop 'следующая итерация цикла
End Sub

Option Explicit
Dim i As Integer, j As Integer, x As Integer, y As Integer
Dim a As Integer, x1 As Integer, y1 As Integer
Dim v As Integer, x2 As Integer, y2 As Integer
Dim map(16, 19) As Integer, field As String
Dim tok As Byte, n As Integer
 
Private Sub Form_Load()
field = "0111111111111111110010000000000000001001011010111010110100101001010101001010010101100000110101001000100111001000100101110011100111010010000000000000001001011100111001110100100010011100100010010100100000100101001010010101010110100101101011101011010010000000000000001001111111111111111100000000000000000000"
    For x = 1 To 16
    For y = 1 To 19
        If Mid(field, ((x * 19 + y) - 19), 1) = "1" Then
            map(x, y) = 1
        Else
            map(x, y) = 0
        End If
    Next y
    Next x
'================== генерация 8 кружков + 1 человечка
Randomize Timer
    a = 0
Do While (a < 9) 'наше количество мин
    x = Rnd * 12: y = Rnd * 14
    x = x + 2: y = y + 2
    If map(x, y) = "0" Then
        map(x, y) = 3 '     "O"
        a = a + 1
        End If
    Loop 'следующая итерация цикла
        map(x, y) = 2 '     "X"
'==================
    tok = 0
        Call Info 'информация
End Sub
 
Private Sub Комманда1_Click()
    tmrTimer.Interval = 500
    picFieldInfo.Visible = False
End Sub
 
 
Private Sub tmrTimer_Timer()
'    Debug.Print x, y
    a = 0
    For i = x - 2 To x + 2
    For j = y - 2 To y + 2
    a = a + 1
    If map(i, j) = 0 Then imgImage(a).Picture = ColImg.ListImages("pic100").Picture 'пустота
    If map(i, j) = 1 Then imgImage(a).Picture = ColImg.ListImages("pic101").Picture 'куст
    If map(i, j) = 2 Then imgImage(a).Picture = ColImg.ListImages("pic102").Picture 'человечек
    If map(i, j) = 3 Then imgImage(a).Picture = ColImg.ListImages("pic103").Picture 'кружок
    If map(i, j) = 9 Then imgImage(a).Picture = ColImg.ListImages("pic109").Picture 'камень
    Next j, i
    If Rnd * 10 > 9 Then
        x2 = Rnd * 12 + 2: y2 = Rnd * 14 + 2:
        If map(x2, y2) = 0 Then map(x2, y2) = 9: Debug.Print "bomb"
    End If
    If tok = 8 Then MsgBox "ТЕПЕРЬ БЫСТРО СМАТЫВАТЬСЯ С ПЛАНЕТЫ": End
End Sub
 
Private Sub picField_KeyDown(KeyCode As Integer, Shift As Integer)
    map(x, y) = 0
    x1 = x: y1 = y
Select Case KeyCode
    Case 38      'вверх
        x = x - 1
    Case 40      'вниз
        x = x + 1
    Case 37      'влево
        y = y - 1
    Case 39      'вправо
        y = y + 1
    Case 27      'ESC
        End
    Case 113     'F2-игра
        'ИнформационнаяФорма.Hide
End Select
    If map(x, y) = 1 Or map(x, y) = 9 Then x = x1: y = y1
    If map(x, y) = 3 Then map(x, y) = 0: tok = tok + 1
        lblChet.Caption = "осталось - " & 8 - tok
    map(x, y) = 2
End Sub
 
Private Sub Info()
'    picFieldInfo.PSet (65, 150), vbBlack 'точка
    picFieldInfo.ForeColor = 128
    picFieldInfo.FontBold = True
    picFieldInfo.FontUnderline = True
    picFieldInfo.FontSize = 24
    picFieldInfo.Print "  2D Mini Maze  "
    picFieldInfo.FontUnderline = False
    picFieldInfo.FontSize = 12
    picFieldInfo.ForeColor = 134526
    picFieldInfo.Print ""
    picFieldInfo.Print "  Собрать в лабиринте 8"
    picFieldInfo.Print " контейнеров с топливом"
    picFieldInfo.Print " при   этом   вам   будут"
    picFieldInfo.Print " преграждать      дорогу"
    picFieldInfo.Print " черные монстры"
    picFieldInfo.FontBold = False
End Sub

Option Explicit
Dim strA As String ' набор Цифр
Dim strB As String ' набор Английских букв
Dim strC As String ' набор Русских букв
Dim strD(4, 4) As String 'двоичный массив из одномерного
Dim strE As String 'строка из двухмерного массива
Dim l As Integer 'счетчик, считает общее количество ходов
Dim i As Integer 'для счетчиков
Dim r As Integer, p As Integer, s As Integer, q As Integer 'переменные для обмена дырки с соседями
Dim x As Byte, y As Byte 'координы строки и столбца
Dim m As Byte, n As Byte
 
Private Sub Form_Load() 'выводит на экран краткую инструкция
    picTable.AutoRedraw = True
    picTable.ForeColor = 3438526
    picTable.FontBold = True
    picTable.FontUnderline = True
    picTable.FontSize = 16
    picTable.Print "         15 - Пятнашки          "
    picTable.FontUnderline = False
    picTable.FontSize = 12
    picTable.ForeColor = 35
    picTable.Print ""
    picTable.Print "    Сюжет  прост  -  раставить"
    picTable.Print " по     порядку     клетки    со"
    picTable.Print " значками."
    picTable.ForeColor = 9254732
    picTable.Print "     выберите  тип  значков:"
    picTable.FontBold = False
End Sub
 
Private Sub cmdStart_Click()
strA = "123456789PQRSTU " 'набор символов
strB = "ABCDEFGHIJKLMNO "
strC = "АБВГДЕЖЗИКЛМНОП "
    If optButtonNumber = True Then strE = strA 'выбор набора символов
    If optButtonEng = True Then strE = strB
    If optButtonRus = True Then strE = strC
 
frmFrame.Visible = False 'спрятать рамку
cmdStart.Visible = False ' спрятат кнопку
    i = 1: p = 4: q = 4: l = 0 ' l - количество ходов
    For y = 1 To 4: For x = 1 To 4 'набор символов в двухмерный массив
    strD(y, x) = Mid(strE, i, 1): i = i + 1 'i - номер позиции в строке
    Next x: Next y 'координаты строки и столбца
        Call Meshalka 'перемешать все символы
        Call InfoTable 'вывести на табло
End Sub
 
Private Sub imgLetter_Click(Index As Integer)
Dim pos As Byte
    pos = imgLetter(Index).Index
    y = Int((pos + 4 - 1) / 4)
    x = (pos + 4) - y * 4
r = p: s = q 'дублировать координаты дырки
    If y + 1 <> 5 Then If strD(y + 1, x) = " " Then r = p - 1 'дырка вверх
    If strD(y - 1, x) = " " Then r = p + 1 'дырка вниз
    If x + 1 <> 5 Then If strD(y, x + 1) = " " Then s = q - 1 'дырка вправо
    If strD(y, x - 1) = " " Then s = q + 1 'дырка влево
    Call Moving
End Sub
 
Private Sub picTable_KeyDown(KeyCode As Integer, Shift As Integer) 'управление клавишами
 r = p: s = q 'дублировать координаты дырки
Select Case KeyCode
    Case 38: r = p + 1     'вверх
    Case 40: r = p - 1     'вниз
    Case 37: s = q + 1     'влево
    Case 39: s = q - 1     'вправо
    Case 27: End     'ESC
    Case 113     'F2-игра
End Select
    Call Moving
End Sub
 
Sub Moving()
l = l + 1: lblSteps.Caption = "ходов - " & l 'выводит кол-во джижений
    If s > 4 Or s < 1 Or r < 1 Or r > 4 Then 'проверка выхода за пределы границ
        r = p: s = q: Exit Sub 'если ДА выйти из подпрограммы
    Else
        strD(p, q) = strD(r, s): strD(r, s) = " " 'если НЕТ поменять местами дырку и символ
        p = r: q = s
    End If
        Call InfoTable 'вывести на табло
End Sub
 
Sub InfoTable() 'вывод информации в табло
strE = ""
Dim lett As String
    For y = 1 To 4: For x = 1 To 4
    strE = strE & strD(y, x)
    Next x: Next y
For i = 1 To 16
lett = Mid(strE, i, 1)
    If lett = " " Then imgLetter(i).Picture = ColImg.ListImages("let0").Picture
    If lett = "A" Then imgLetter(i).Picture = ColImg.ListImages("letA").Picture
    If lett = "B" Then imgLetter(i).Picture = ColImg.ListImages("letB").Picture
    If lett = "C" Then imgLetter(i).Picture = ColImg.ListImages("letC").Picture
    If lett = "D" Then imgLetter(i).Picture = ColImg.ListImages("letD").Picture
    If lett = "E" Then imgLetter(i).Picture = ColImg.ListImages("letE").Picture
    If lett = "F" Then imgLetter(i).Picture = ColImg.ListImages("letF").Picture
    If lett = "G" Then imgLetter(i).Picture = ColImg.ListImages("letG").Picture
    If lett = "H" Then imgLetter(i).Picture = ColImg.ListImages("letH").Picture
    If lett = "I" Then imgLetter(i).Picture = ColImg.ListImages("letI").Picture
    If lett = "J" Then imgLetter(i).Picture = ColImg.ListImages("letJ").Picture
    If lett = "K" Then imgLetter(i).Picture = ColImg.ListImages("letK").Picture
    If lett = "L" Then imgLetter(i).Picture = ColImg.ListImages("letL").Picture
    If lett = "M" Then imgLetter(i).Picture = ColImg.ListImages("letM").Picture
    If lett = "N" Then imgLetter(i).Picture = ColImg.ListImages("letN").Picture
    If lett = "O" Then imgLetter(i).Picture = ColImg.ListImages("letO").Picture
    If lett = "А" Then imgLetter(i).Picture = ColImg.ListImages("letА").Picture
    If lett = "Б" Then imgLetter(i).Picture = ColImg.ListImages("letБ").Picture
    If lett = "В" Then imgLetter(i).Picture = ColImg.ListImages("letВ").Picture
    If lett = "Г" Then imgLetter(i).Picture = ColImg.ListImages("letГ").Picture
    If lett = "Д" Then imgLetter(i).Picture = ColImg.ListImages("letД").Picture
    If lett = "Е" Then imgLetter(i).Picture = ColImg.ListImages("letЕ").Picture
    If lett = "Ж" Then imgLetter(i).Picture = ColImg.ListImages("letЖ").Picture
    If lett = "З" Then imgLetter(i).Picture = ColImg.ListImages("letЗ").Picture
    If lett = "И" Then imgLetter(i).Picture = ColImg.ListImages("letИ").Picture
    If lett = "К" Then imgLetter(i).Picture = ColImg.ListImages("letК").Picture
    If lett = "Л" Then imgLetter(i).Picture = ColImg.ListImages("letЛ").Picture
    If lett = "М" Then imgLetter(i).Picture = ColImg.ListImages("letМ").Picture
    If lett = "Н" Then imgLetter(i).Picture = ColImg.ListImages("letН").Picture
    If lett = "О" Then imgLetter(i).Picture = ColImg.ListImages("letО").Picture
    If lett = "П" Then imgLetter(i).Picture = ColImg.ListImages("letП").Picture
    If lett = "1" Then imgLetter(i).Picture = ColImg.ListImages("let1").Picture
    If lett = "2" Then imgLetter(i).Picture = ColImg.ListImages("let2").Picture
    If lett = "3" Then imgLetter(i).Picture = ColImg.ListImages("let3").Picture
    If lett = "4" Then imgLetter(i).Picture = ColImg.ListImages("let4").Picture
    If lett = "5" Then imgLetter(i).Picture = ColImg.ListImages("let5").Picture
    If lett = "6" Then imgLetter(i).Picture = ColImg.ListImages("let6").Picture
    If lett = "7" Then imgLetter(i).Picture = ColImg.ListImages("let7").Picture
    If lett = "8" Then imgLetter(i).Picture = ColImg.ListImages("let8").Picture
    If lett = "9" Then imgLetter(i).Picture = ColImg.ListImages("let9").Picture
    If lett = "P" Then imgLetter(i).Picture = ColImg.ListImages("letP").Picture
    If lett = "Q" Then imgLetter(i).Picture = ColImg.ListImages("letQ").Picture
    If lett = "R" Then imgLetter(i).Picture = ColImg.ListImages("letR").Picture
    If lett = "S" Then imgLetter(i).Picture = ColImg.ListImages("letS").Picture
    If lett = "T" Then imgLetter(i).Picture = ColImg.ListImages("letT").Picture
    If lett = "U" Then imgLetter(i).Picture = ColImg.ListImages("letU").Picture
Next i
    If strA = strE Then MsgBox "OK! Задача решена!": End
    If strB = strE Then MsgBox "OK! Задача решена!": End
    If strC = strE Then MsgBox "OK! Задача решена!": End
End Sub
 
Sub Meshalka() 'перемешивает символы
i = 0 'перемешивание без оператора GO TO
Do While (i < 250) 'зациклить в 250 раз
    r = p: s = q
    Randomize: n = Int(Rnd * 4) + 5
    If n = 5 And s < 4 Then s = q + 1
    If n = 8 And s > 1 Then s = q - 1
    If n = 6 And r > 1 Then r = p - 1
    If n = 7 And r < 4 Then r = p + 1
    strD(p, q) = strD(r, s): strD(r, s) = " "
    i = i + 1 'увеличиваем счетчик на 1
    p = r: q = s
Loop 'следующая итерация цикла
End Sub

Option Explicit
'классический против компа
Dim step As Byte
Dim I As Long
Dim A11 As Byte, A12 As Byte, A13 As Byte
Dim A21 As Byte, A22 As Byte, A23 As Byte
Dim A31 As Byte, A32 As Byte, A33 As Byte
Dim B11 As Byte, B12 As Byte, B13 As Byte
Dim B21 As Byte, B22 As Byte, B23 As Byte
Dim B31 As Byte, B32 As Byte, B33 As Byte
 
 
Private Sub Form_Load()
    B11 = 0: B12 = 0: B13 = 0
    B21 = 0: B22 = 0: B23 = 0
    B31 = 0: B32 = 0: B33 = 0
End Sub
 
 
Private Sub IMG11_Click()
    step = step + 1
    B11 = 1
    If step = 1 Then Call step1
    If step = 2 Then Call step2
    If step = 3 Then Call step1
    If step = 4 Then Call step4
    If step = 5 Then Call step1
    If step = 6 Then Call step6
    If step = 7 Then Call step1
    If step = 8 Then Call step6
    If step = 9 Then Call step1
    Call proverka
End Sub
Private Sub IMG12_Click()
    step = step + 1
    B12 = 1
    If step = 1 Then Call step1
    If step = 2 Then Call step2
    If step = 3 Then Call step1
    If step = 4 Then Call step4
    If step = 5 Then Call step1
    If step = 6 Then Call step6
    If step = 7 Then Call step1
    If step = 8 Then Call step6
    If step = 9 Then Call step1
    Call proverka
End Sub
Private Sub IMG13_Click()
    step = step + 1
    B13 = 1
    If step = 1 Then Call step1
    If step = 2 Then Call step2
    If step = 3 Then Call step1
    If step = 4 Then Call step4
    If step = 5 Then Call step1
    If step = 6 Then Call step6
    If step = 7 Then Call step1
    If step = 8 Then Call step6
    If step = 9 Then Call step1
    Call proverka
End Sub
Private Sub IMG21_Click()
    step = step + 1
    B21 = 1
    If step = 1 Then Call step1
    If step = 2 Then Call step2
    If step = 3 Then Call step1
    If step = 4 Then Call step4
    If step = 5 Then Call step1
    If step = 6 Then Call step6
    If step = 7 Then Call step1
    If step = 8 Then Call step6
    If step = 9 Then Call step1
    Call proverka
End Sub
Private Sub IMG22_Click()
    step = step + 1
    B22 = 1
    If step = 1 Then Call step1
    If step = 2 Then Call step2
    If step = 3 Then Call step1
    If step = 4 Then Call step4
    If step = 5 Then Call step1
    If step = 6 Then Call step6
    If step = 7 Then Call step1
    If step = 8 Then Call step6
    If step = 9 Then Call step1
    Call proverka
End Sub
Private Sub IMG23_Click()
    step = step + 1
    B23 = 1
    If step = 1 Then Call step1
    If step = 2 Then Call step2
    If step = 3 Then Call step1
    If step = 4 Then Call step4
    If step = 5 Then Call step1
    If step = 6 Then Call step6
    If step = 7 Then Call step1
    If step = 8 Then Call step6
    If step = 9 Then Call step1
    Call proverka
End Sub
Private Sub IMG31_Click()
    step = step + 1
    B31 = 1
    If step = 1 Then Call step1
    If step = 2 Then Call step2
    If step = 3 Then Call step1
    If step = 4 Then Call step4
    If step = 5 Then Call step1
    If step = 6 Then Call step6
    If step = 7 Then Call step1
    If step = 8 Then Call step6
    If step = 9 Then Call step1
    Call proverka
End Sub
Private Sub IMG32_Click()
    step = step + 1
    B32 = 1
    If step = 1 Then Call step1
    If step = 2 Then Call step2
    If step = 3 Then Call step1
    If step = 4 Then Call step4
    If step = 5 Then Call step1
    If step = 6 Then Call step6
    If step = 7 Then Call step1
    If step = 8 Then Call step6
    If step = 9 Then Call step1
    Call proverka
End Sub
Private Sub IMG33_Click()
    step = step + 1
    B33 = 1
    If step = 1 Then Call step1
    If step = 2 Then Call step2
    If step = 3 Then Call step1
    If step = 4 Then Call step4
    If step = 5 Then Call step1
    If step = 6 Then Call step6
    If step = 7 Then Call step1
    If step = 8 Then Call step6
    If step = 9 Then Call step1
    Call proverka
End Sub
 
Sub step1()
    If B11 = 1 Then
        IMG11.Picture = LoadPicture("001.bmp")
    End If
    If B12 = 1 Then
        IMG12.Picture = LoadPicture("001.bmp")
    End If
    If B13 = 1 Then
        IMG13.Picture = LoadPicture("001.bmp")
    End If
    If B21 = 1 Then
        IMG21.Picture = LoadPicture("001.bmp")
    End If
    If B22 = 1 Then
        IMG22.Picture = LoadPicture("001.bmp")
    End If
    If B23 = 1 Then
        IMG23.Picture = LoadPicture("001.bmp")
    End If
    If B31 = 1 Then
        IMG31.Picture = LoadPicture("001.bmp")
    End If
    If B32 = 1 Then
        IMG32.Picture = LoadPicture("001.bmp")
    End If
    If B33 = 1 Then
        IMG33.Picture = LoadPicture("001.bmp")
    End If
    step = step + 1
End Sub
 
Sub step2()
Dim p As Byte
    Randomize
    p = 8 * Rnd() + 1
    If p = 1 And B11 = 0 Then
        B11 = 2
        IMG11.Picture = LoadPicture("002.bmp")
    ElseIf p = 2 And B12 = 0 Then
        B12 = 2
        IMG12.Picture = LoadPicture("002.bmp")
    ElseIf p = 3 And B13 = 0 Then
        B13 = 2
        IMG13.Picture = LoadPicture("002.bmp")
    ElseIf p = 4 And B21 = 0 Then
        B21 = 2
        IMG21.Picture = LoadPicture("002.bmp")
    ElseIf p = 5 And B22 = 0 Then
        B22 = 2
        IMG22.Picture = LoadPicture("002.bmp")
    ElseIf p = 6 And B23 = 0 Then
        B23 = 2
        IMG23.Picture = LoadPicture("002.bmp")
    ElseIf p = 7 And B31 = 0 Then
        B31 = 2
        IMG31.Picture = LoadPicture("002.bmp")
    ElseIf p = 8 And B32 = 0 Then
        B32 = 2
        IMG32.Picture = LoadPicture("002.bmp")
    ElseIf p = 9 And B33 = 0 Then
        B33 = 2
        IMG33.Picture = LoadPicture("002.bmp")
    Else
        step2
    End If
End Sub
 
' =========================================================================
Sub step4()
    If B11 = 0 And B12 = 1 And B13 = 1 Then
        B11 = 2
        IMG11.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 1 And B12 = 0 And B13 = 1 Then
        B12 = 2
        IMG12.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 1 And B12 = 1 And B13 = 0 Then
        B13 = 2
        IMG13.Picture = LoadPicture("002.bmp")
    ElseIf B21 = 0 And B22 = 1 And B23 = 1 Then
        B21 = 2
        IMG21.Picture = LoadPicture("002.bmp")
    ElseIf B21 = 1 And B22 = 0 And B23 = 1 Then
        B22 = 2
        IMG22.Picture = LoadPicture("002.bmp")
    ElseIf B21 = 1 And B22 = 1 And B23 = 0 Then
        B23 = 2
        IMG23.Picture = LoadPicture("002.bmp")
    ElseIf B31 = 0 And B32 = 1 And B33 = 1 Then
        B31 = 2
        IMG31.Picture = LoadPicture("002.bmp")
    ElseIf B31 = 1 And B32 = 0 And B33 = 1 Then
        B32 = 2
        IMG32.Picture = LoadPicture("002.bmp")
    ElseIf B31 = 1 And B32 = 1 And B33 = 0 Then
        B33 = 2
        IMG33.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 0 And B21 = 1 And B31 = 1 Then '----------------- вертикаль --------------------
        B11 = 2
        IMG11.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 1 And B21 = 0 And B31 = 1 Then
        B21 = 2
        IMG21.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 1 And B21 = 1 And B31 = 0 Then
        B31 = 2
        IMG31.Picture = LoadPicture("002.bmp")
    ElseIf B12 = 0 And B22 = 1 And B32 = 1 Then
        B12 = 2
        IMG12.Picture = LoadPicture("002.bmp")
    ElseIf B12 = 1 And B22 = 0 And B32 = 1 Then
        B22 = 2
        IMG22.Picture = LoadPicture("002.bmp")
    ElseIf B12 = 1 And B22 = 1 And B32 = 0 Then
        B32 = 2
        IMG32.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 0 And B23 = 1 And B33 = 1 Then
        B13 = 2
        IMG13.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 1 And B23 = 0 And B33 = 1 Then
        B23 = 2
        IMG23.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 1 And B23 = 1 And B33 = 0 Then
        B33 = 2
        IMG33.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 0 And B22 = 1 And B33 = 1 Then '--------------------диагональ --------
        B11 = 2
        IMG11.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 1 And B22 = 0 And B33 = 1 Then
        B22 = 2
        IMG22.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 1 And B22 = 1 And B33 = 0 Then
        B33 = 2
        IMG33.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 0 And B22 = 1 And B31 = 1 Then
        B13 = 2
        IMG13.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 1 And B22 = 0 And B31 = 1 Then
        B22 = 2
        IMG22.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 1 And B22 = 1 And B31 = 0 Then
        B31 = 2
        IMG31.Picture = LoadPicture("002.bmp")
    Else
        Call step2
    End If
End Sub
 
' =========================================================================
Sub step6()
    If B11 = 0 And B12 = 2 And B13 = 2 Then
        B11 = 2
        IMG11.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 2 And B12 = 0 And B13 = 2 Then
        B12 = 2
        IMG12.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 2 And B12 = 2 And B13 = 0 Then
        B13 = 2
        IMG13.Picture = LoadPicture("002.bmp")
    ElseIf B21 = 0 And B22 = 2 And B23 = 2 Then
        B21 = 2
        IMG21.Picture = LoadPicture("002.bmp")
    ElseIf B21 = 2 And B22 = 0 And B23 = 2 Then
        B22 = 2
        IMG22.Picture = LoadPicture("002.bmp")
    ElseIf B21 = 2 And B22 = 2 And B23 = 0 Then
        B23 = 2
        IMG23.Picture = LoadPicture("002.bmp")
    ElseIf B31 = 0 And B32 = 2 And B33 = 2 Then
        B31 = 2
        IMG31.Picture = LoadPicture("002.bmp")
    ElseIf B31 = 2 And B32 = 0 And B33 = 2 Then
        B32 = 2
        IMG32.Picture = LoadPicture("002.bmp")
    ElseIf B31 = 2 And B32 = 2 And B33 = 0 Then
        B33 = 2
        IMG33.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 0 And B21 = 2 And B31 = 2 Then '----------------- вертикаль --------------------
        B11 = 2
        IMG11.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 2 And B21 = 0 And B31 = 2 Then
        B21 = 2
        IMG21.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 2 And B21 = 2 And B31 = 0 Then
        B31 = 2
        IMG31.Picture = LoadPicture("002.bmp")
    ElseIf B12 = 0 And B22 = 2 And B32 = 2 Then
        B12 = 2
        IMG12.Picture = LoadPicture("002.bmp")
    ElseIf B12 = 2 And B22 = 0 And B32 = 2 Then
        B22 = 2
        IMG22.Picture = LoadPicture("002.bmp")
    ElseIf B12 = 2 And B22 = 2 And B32 = 0 Then
        B32 = 2
        IMG32.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 0 And B23 = 2 And B33 = 2 Then
        B13 = 2
        IMG13.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 2 And B23 = 0 And B33 = 2 Then
        B23 = 2
        IMG23.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 2 And B23 = 2 And B33 = 0 Then
        B33 = 2
        IMG33.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 0 And B22 = 2 And B33 = 2 Then '--------------------диагональ --------
        B11 = 2
        IMG11.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 2 And B22 = 0 And B33 = 2 Then
        B22 = 2
        IMG22.Picture = LoadPicture("002.bmp")
    ElseIf B11 = 2 And B22 = 2 And B33 = 0 Then
        B33 = 2
        IMG33.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 0 And B22 = 2 And B31 = 2 Then
        B13 = 2
        IMG13.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 2 And B22 = 0 And B31 = 2 Then
        B22 = 2
        IMG22.Picture = LoadPicture("002.bmp")
    ElseIf B13 = 2 And B22 = 2 And B31 = 0 Then
        B31 = 2
        IMG31.Picture = LoadPicture("002.bmp")
    Else
        Call step4
    End If
End Sub
 
 
Sub proverka()
    If B11 = 1 And B12 = 1 And B13 = 1 Then
        Call Victory
    ElseIf B21 = 1 And B22 = 1 And B23 = 1 Then
        Call Victory
    ElseIf B31 = 1 And B32 = 1 And B33 = 1 Then
        Call Victory
    ElseIf B11 = 1 And B21 = 1 And B31 = 1 Then
        Call Victory
    ElseIf B12 = 1 And B22 = 1 And B32 = 1 Then
        Call Victory
    ElseIf B13 = 1 And B23 = 1 And B33 = 1 Then
        Call Victory
    ElseIf B11 = 1 And B22 = 1 And B33 = 1 Then
        Call Victory
    ElseIf B13 = 1 And B22 = 1 And B31 = 1 Then
        Call Victory
    ElseIf B11 = 2 And B12 = 2 And B13 = 2 Then
        Call Loss
    ElseIf B21 = 2 And B22 = 2 And B23 = 2 Then
        Call Loss
    ElseIf B31 = 2 And B32 = 2 And B33 = 2 Then
        Call Loss
    ElseIf B11 = 2 And B21 = 2 And B31 = 2 Then
        Call Loss
    ElseIf B12 = 2 And B22 = 2 And B32 = 2 Then
        Call Loss
    ElseIf B13 = 2 And B23 = 2 And B33 = 2 Then
        Call Loss
    ElseIf B11 = 2 And B22 = 2 And B33 = 2 Then
        Call Loss
    ElseIf B13 = 2 And B22 = 2 And B31 = 2 Then
        Call Loss
    ElseIf step = 10 Then
            Label1.Caption = "Ничья"
                Call PlayStop
    End If
End Sub
 
        Sub Victory()
            Label1.Caption = "Выигрыш"
                Call PlayStop
        End Sub
        Sub Loss()
            Label1.Caption = "Проигрыш"
                Call PlayStop
        End Sub
 
        Sub PlayStop() 'запрос на новую игру или выход
        Dim V As Byte
                V = MsgBox("Еще сыграем?", 36, "Запрос")
                If V = 6 Then
                        step = 0
                        B11 = 0: B12 = 0: B13 = 0
                        B21 = 0: B22 = 0: B23 = 0
                        B31 = 0: B32 = 0: B33 = 0
                        IMG11.Picture = LoadPicture("000.bmp")
                        IMG12.Picture = LoadPicture("000.bmp")
                        IMG13.Picture = LoadPicture("000.bmp")
                        IMG21.Picture = LoadPicture("000.bmp")
                        IMG22.Picture = LoadPicture("000.bmp")
                        IMG23.Picture = LoadPicture("000.bmp")
                        IMG31.Picture = LoadPicture("000.bmp")
                        IMG32.Picture = LoadPicture("000.bmp")
                        IMG33.Picture = LoadPicture("000.bmp")
                        Label1.Caption = ""
                Else
                        End
                End If
        End Sub

Option Explicit
Dim map As String
Dim chet As Integer
Dim i As Integer, o As Integer, z As Integer, x As Integer
Dim p As Integer, m As Integer, n As Integer, q As Integer
Dim way As String
Dim arr(5) As String, plus(5) As String
Dim ver As Integer
 
 
Private Sub Form_Load()
    ver = 1
    picField.ScaleMode = 0 'пользовательский тип
    picField.Scale (0, 175)-(255, 0) 'размер поля
    picField.DrawWidth = 2 'толщина точки
    Call MapMake 'загнать в память данные лабиринта
End Sub
 
 
Private Sub picField_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 38 And Mid(map, (p + o), 1) = "1" Then 'если впереди стена, то стоп
            Exit Sub
    End If
    If KeyCode = 38 Then 'полный вперед
            p = p + o
    End If
    If KeyCode = 37 Then 'поворот на лево
            o = o - 1
            Call GSB5060
    End If
    If KeyCode = 39 Then 'поврот на право
            o = o + 1
            Call GSB5060
    End If
            '------------------------- кнопка [вниз] --попытка вывести карту через кнопку
'    If KeyCode = 40 Then
'            Debug.Print "назад"
'            p = p - o
'    End If
            '------------------------- кнопка [1] ------------------------------
'    If KeyCode = 49 And picField.Visible = True Then
'        picField.Visible = False
'        Call mapOutput
'    End If
 
Call Basic
    'Case 27      'ESC
    '    End
    'Case 113     'F2-игра
    If p = z Then 'если лабиринт пройден
        ver = ver + 1 'переходим на новый
        If ver = 5 Then MsgBox "ВСЕ УРОВНИ ПРОЙДЕНЫ ! ! !": End 'если все 4 лабиринта то выход
        MsgBox "ВЫХОД НАЙДЕН !!! ПРОДОЛЖИМ ?"
        lblInfo.Caption = "Уровень " & ver
        Call MapMake
        Call mapOutput
    End If
End Sub
 
Sub Basic()
' p+Х*o ="1"- вереди стена на Х шагов (горизонтальные линии - сверху и снизу)
' p+o+n="1"
m2000: picField.Cls: picField.BackColor = vbYellow
m2010: picField.Line (24, 167)-(24, 12), vbBlack 'слева 1 -ая вертикальная
            picField.Line (231, 167)-(231, 12), vbBlack 'справа 1 -ая вертикальная
m2020: m = o: o = o + 1: Call GSB5060
            n = o: o = m: m = n: n = o: o = o - 1: Call GSB5060
            q = o: o = n: n = q
m2024: If Mid(map, (p + n), 1) = "0" Then GoTo m3500
m2026: picField.Line (16, 175)-(23, 168), vbBlack 'слева верхняя 1-ая горизонтальная линия
            picField.Line (0, 0)-(24, 12), vbBlack 'слева нижняя 1-ая горизонтальная линия
m2030: If Mid(map, (p + m), 1) = "0" Then GoTo m3550
m2040: picField.Line (239, 175)-(232, 168), vbBlack 'справа верхняя 1-ая горизонтальная линия
            picField.Line (255, 0)-(231, 12), vbBlack 'справа нижняя 1-ая горизонтальная линия
m2070: If Mid(map, (p + o), 1) = "1" Then picField.Line (24, 167)-(231, 167), vbBlack: picField.Line (24, 12)-(231, 12), vbBlack: GoTo m5000 '=0-стена впереди 1-верх. 2-низ =
m2090: picField.Line (64, 127)-(64, 32), vbBlack 'слева 2-ая вертикальная
            picField.Line (191, 127)-(191, 32), vbBlack 'справа 2-ая вертикальная
            If Mid(map, (p + o + n), 1) = "0" Then GoTo m3600
m2100: picField.Line (24, 167)-(64, 127), vbBlack ' слева 2-ая вехняя
       picField.Line (24, 12)-(64, 32), vbBlack ' слева 2-ая нижняя
m2110: If Mid(map, (p + o + m), 1) = "0" Then GoTo m3650
m2120: picField.Line (191, 127)-(231, 167), vbBlack 'справа 2-ая вехняя
       picField.Line (231, 12)-(191, 32), vbBlack 'справа 2-ая нижняя
m2130: If Mid(map, (p + o + o), 1) = "1" Then picField.Line (64, 127)-(190, 127), vbBlack: picField.Line (64, 32)-(190, 32), vbBlack: GoTo m5000 '=1-стена впереди 1-верх, 2-низ =
m2140: picField.Line (88, 103)-(88, 44), vbBlack 'слева 3-ая вертикальная
       picField.Line (167, 103)-(167, 44), vbBlack 'справа 3-ая вертикальная
m2150: If Mid(map, (p + o + o + n), 1) = "0" Then GoTo m3700
m2160: picField.Line (88, 103)-(64, 127), vbBlack 'слева 3-ая вехняя
       picField.Line (88, 44)-(65, 33), vbBlack 'слева 3-ая нижняя
m2170: If Mid(map, (p + o + o + m), 1) = "0" Then GoTo m3750
m2180: picField.Line (167, 103)-(191, 127), vbBlack 'справа 3-ая вехняя
       picField.Line (167, 44)-(190, 33), vbBlack 'справа 3-ая нижняя
m2190: If Mid(map, (p + 3 * o), 1) = "1" Then picField.Line (88, 103)-(167, 103), vbBlack: picField.Line (88, 44)-(167, 44), vbBlack: GoTo m5000 '=2-стена впереди 1-верх, 2-вниз
m2200: picField.Line (104, 87)-(104, 52), vbBlack 'слева 4-ая вертикальная
       picField.Line (151, 87)-(151, 52), vbBlack 'справа 4-ая вертикальная
m2210: If Mid(map, (p + o * 3 + n), 1) = "0" Then GoTo m3800
m2220: picField.Line (104, 87)-(88, 103), vbBlack 'слева 4-ая вехняя
       picField.Line (104, 52)-(89, 45), vbBlack 'слева 4-ая нижняя
m2230: If Mid(map, (p + 3 * o + m), 1) = "0" Then GoTo m3850
m2240: picField.Line (151, 87)-(167, 103), vbBlack 'справа 4-ая вехняя
       picField.Line (151, 52)-(166, 45), vbBlack 'справа 4-ая нижняя
m2250: If Mid(map, (p + 4 * o), 1) = "1" Then picField.Line (104, 87)-(151, 87), vbBlack: picField.Line (104, 52)-(151, 52), vbBlack: GoTo m5000 '=3-стена впереди 1-верх, 2-низ
m2260: picField.Line (114, 77)-(114, 57), vbBlack 'слева 5-ая вертикальная
       picField.Line (141, 77)-(141, 57), vbBlack 'справа 5-ая вертикальная
m2270: If Mid(map, (p + 4 * o + n), 1) = "0" Then GoTo m3900
m2275: picField.Line (114, 77)-(105, 86), vbBlack 'слева 5-ая вехняя
       picField.Line (113, 57)-(105, 53), vbBlack 'слева 5-ая нижняя
m2280: If Mid(map, (p + 4 * o + m), 1) = "0" Then GoTo m3950
m2290: picField.Line (141, 77)-(150, 86), vbBlack 'справа 5-ая вехняя
       picField.Line (142, 57)-(150, 53), vbBlack 'справа 5-ая нижняя
m2300: If Mid(map, (p + 5 * o), 1) = "1" Then picField.Line (114, 77)-(139, 77), vbBlack: picField.Line (114, 57)-(139, 57), vbBlack: GoTo m5000 '=4-стена впереди=1-верх, 2-низ==
m2310: picField.Line (120, 71)-(120, 61), vbBlack 'слева 6-ая вертикальная
       picField.Line (135, 71)-(135, 61), vbBlack 'справа 6-ая вертикальная
m2320: If Mid(map, (p + 5 * o + n), 1) = "0" Then GoTo m4000
m2330: picField.Line (120, 71)-(114, 77), vbBlack 'слева 6-ая вехняя
       picField.Line (120, 61)-(114, 58), vbBlack 'слева 6-ая нижняя
m2340: If Mid(map, (p + 5 * o + m), 1) = "0" Then GoTo m4050
m2350: picField.Line (135, 71)-(141, 77), vbBlack 'справа 6-ая вехняя
       picField.Line (135, 61)-(141, 58), vbBlack 'справа 6-ая нижняя
m2360: If Mid(map, (p + 6 * o), 1) = "1" Then picField.Line (120, 71)-(135, 71), vbBlack: picField.Line (120, 61)-(135, 61), vbBlack: GoTo m5000 '=5-стена впереди=1-верх, 2-вниз=
m2370: picField.Line (124, 67)-(124, 63), vbBlack '=7-стена впереди=слева
       picField.Line (131, 67)-(131, 63), vbBlack '=7-стена впереди=справа
m2380: If Mid(map, (p + 6 * o + n), 1) = "1" Then picField.Line (124, 67)-(121, 70), vbBlack: picField.Line (124, 63)-(120, 61), vbBlack: GoTo m2400 '=6-корридор=1-верх, 2-вниз==
m2390: If Mid(map, (p + 7 * o + n), 1) = "1" Then picField.Line (124, 67)-(121, 67), vbBlack: picField.Line (124, 63)-(121, 63), vbBlack: GoTo m2400 '=7-стенка слева=1-верх,2-вниз=
m2395: picField.Line (124, 66)-(121, 66), vbBlack: picField.Line (124, 64)-(121, 64), vbBlack '=7-стенка слева=1-верх,2-вниз (дополнение)==
m2400: If Mid(map, (p + 6 * o + m), 1) = "1" Then picField.Line (131, 67)-(134, 70), vbBlack: picField.Line (131, 63)-(135, 61), vbBlack: GoTo m2420 ' 6-корридор=1-сверху,2-снизу==
m2410: If Mid(map, (p + 7 * o + m), 1) = "1" Then picField.Line (131, 67)-(134, 67), vbBlack: picField.Line (131, 63)-(134, 63), vbBlack: GoTo m2420 ' 7-корридор=1-сверху,2-снизу=
m2415: picField.Line (131, 66)-(134, 66), vbBlack: picField.Line (131, 64)-(134, 64)    '  =7-стенка справа=1-верх,2-вниз=
m2420: If Mid(map, (p + 7 * o), 1) = "1" Then picField.Line (124, 67)-(131, 67), vbBlack: picField.Line (124, 63)-(131, 63), vbBlack: GoTo m5000 '=6-стена впереди=1-верх, 2-вниз=
m2430: picField.Line (124, 67)-(127, 64), vbBlack: picField.Line -(125, 64), vbBlack: picField.Line -(122, 63)  ' концовка корридора слева
            picField.Line (131, 67)-(128, 64), vbBlack: picField.Line -(130, 64), vbBlack: picField.Line -(128, 64), vbBlack: picField.Line -(131, 63)  ' концовка корридора справа
m3490: GoTo m5000
m3500: If Mid(map, (p + o + n), 1) = "1" Then picField.Line (0, 12)-(24, 12), vbBlack: picField.Line (0, 167)-(24, 167), vbBlack: GoTo m2030 '=1 слева стена 2-верх, 1-вниз=
m3510: If Mid(map, (p + 2 * o + n), 1) = "1" Then picField.Line (0, 127)-(24, 127), vbBlack: picField.Line (0, 32)-(24, 32), vbBlack: GoTo m2030 '=2 слева стена 2-верх, 1-вниз =
m3520: picField.Line (8, 103)-(8, 44), vbBlack '1-слева сторона вертикаль
       If Mid(map, (p + 3 * o + n), 1) = "1" Then picField.Line (24, 103)-(8, 103), vbBlack: picField.Line (24, 44)-(8, 44) '=3 слева стена 1-верх,2-вниз== =
m3525: If Mid(map, (p + 2 * o + n + n), 1) = "0" Then picField.Line (0, 44)-(8, 44), vbBlack: picField.Line (0, 103)-(8, 103), vbBlack: GoTo m3535 ' =1-слева сторона 2-вниз,  1-верх==
m3530: picField.Line (0, 106)-(8, 104), vbBlack: picField.Line (0, 42)-(8, 44), vbBlack   ' =1-корридор слева=1-верх,2-вниз=
m3535: If Mid(map, (p + 3 * o + n), 1) = "0" Then picField.Line (8, 103)-(24, 99), vbBlack: picField.Line (8, 44)-(24, 48), vbBlack  '=1-корридор слева=1-верх,2-вниз=
m3540:  GoTo m2030
m3550: If Mid(map, (p + o + m), 1) = "1" Then picField.Line (255, 12)-(231, 12), vbBlack: picField.Line (255, 167)-(231, 167), vbBlack: GoTo m2070  '1-справа, верх, низ
m3560: If Mid(map, (p + o + o + m), 1) = "1" Then picField.Line (255, 127)-(231, 127), vbBlack: picField.Line (255, 32)-(231, 32), vbBlack: GoTo m2070  '2-справа, верх, низ
m3570: picField.Line (247, 103)-(247, 44), vbBlack 'угловая вертикаль
       If Mid(map, (p + 3 * o + m), 1) = "1" Then picField.Line (231, 103)-(247, 103), vbBlack: picField.Line (247, 44)-(231, 44), vbBlack ' стенка слева к угловой вертикали
m3575: If Mid(map, (p + 2 * o + m + m), 1) = "0" Then picField.Line (255, 44)-(247, 44), vbBlack: picField.Line (255, 103)-(247, 103), vbBlack: GoTo m3585  '=1-стена=справа,=1-верх,=2-низ=
m3580: picField.Line (255, 106)-(247, 104), vbBlack: picField.Line (255, 42)-(247, 44), vbBlack '=1-корридорный угловой вертикаль,=1-верх,=2-низ=
m3585: If Mid(map, (p + 3 * o + m), 1) = "0" Then picField.Line (247, 103)-(231, 99), vbBlack: picField.Line (247, 44)-(231, 48), vbBlack '=2=справа корридор=1-верх,=2-вниз=
m3590: GoTo m2070
m3600: If Mid(map, (p + 2 * o + n), 1) = "1" Then picField.Line (24, 127)-(64, 127), vbBlack: picField.Line (24, 32)-(64, 32), vbBlack: GoTo m2110  '=2-стенка слева, 1-верх, 2-низ=
m3610: If Mid(map, (p + 3 * o + n), 1) = "1" Then picField.Line (24, 103)-(64, 103), vbBlack: picField.Line (24, 44)-(64, 44), vbBlack: GoTo m2110 '=3-стенка слева, 1-верх, 2-низ=
m3620: picField.Line (55, 87)-(55, 52), vbBlack  ' слева закуток какое-то среднее значение
       If Mid(map, (p + 3 * o + n + n), 1) = "1" Then picField.Line -(63, 54), vbBlack: picField.Line (55, 87)-(63, 84), vbBlack: picField.Line (55, 87)-(24, 98), vbBlack: picField.Line (55, 52)-(24, 46), vbBlack: GoTo m2110 ' слева закуток какое-то среднее значение
m3625: picField.Line (55, 87)-(24, 87), vbBlack: picField.Line (55, 52)-(24, 52), vbBlack: picField.Line (55, 87)-(63, 87), vbBlack: picField.Line (55, 52)-(63, 52), vbBlack: GoTo m2110 '' слева закуток какое-то среднее значение все горизонтально
m3650: If Mid(map, (p + 2 * o + m), 1) = "1" Then picField.Line (231, 127)-(191, 127), vbBlack: picField.Line (231, 32)-(191, 32), vbBlack: GoTo m2130  '2-стенка справа,=1-верх,=2-вниз=
m3660: If Mid(map, (p + 3 * o + m), 1) = "1" Then picField.Line (231, 103)-(191, 103), vbBlack: picField.Line (231, 44)-(191, 44), vbBlack: GoTo m2130  '2-стенка справа,=1-верх,=2-вниз=в закоуттке
m3670: picField.Line (200, 87)-(200, 52), vbBlack 'вертикаль коридорная справа
            If Mid(map, (p + 3 * o + m + m), 1) = "1" Then picField.Line -(192, 54), vbBlack: picField.Line (200, 87)-(192, 84), vbBlack: picField.Line (200, 87)-(231, 98), vbBlack: picField.Line (200, 52)-(231, 45), vbBlack: GoTo m2130 'низ,верх,верх,низ - горизонтали у вертикали коридорной
m3675: picField.Line (200, 87)-(231, 87), vbBlack: picField.Line (200, 52)-(231, 52), vbBlack: picField.Line (200, 87)-(192, 87), vbBlack: picField.Line (200, 52)-(192, 52), vbBlack: GoTo m2130 'горизонтали справа в середине
m3700: If Mid(map, (p + 3 * o + n), 1) = "1" Then picField.Line (88, 103)-(65, 103), vbBlack: picField.Line (88, 44)-(65, 44), vbBlack: GoTo m2170 '=3 слева от стенки две горизонтальные черточки
m3705: If Mid(map, (p + 4 * o + n), 1) = "1" Then picField.Line (88, 87)-(65, 87), vbBlack: picField.Line (88, 52)-(65, 52), vbBlack: GoTo m2170 '=4 слева стена 1-верх, 2-вниз===
m3710: picField.Line (80, 79)-(80, 56), vbBlack 'слева вертикаль по середине
       If Mid(map, (p + 4 * o + 2 * n), 1) = "0" Then picField.Line -(65, 56), vbBlack: picField.Line (80, 79)-(65, 79), vbBlack: picField.Line (80, 79)-(87, 79), vbBlack: picField.Line (80, 56)-(87, 56), vbBlack: GoTo m2170 'горизонтаьные черточки от вертикали
m3720: picField.Line -(66, 53), vbBlack: picField.Line (80, 79)-(65, 84), vbBlack: picField.Line (80, 79)-(88, 76), vbBlack: picField.Line (80, 56)-(87, 57), vbBlack: GoTo m2170 '4 слева корридор горизонтальные черточки от вертикали
m3750: If Mid(map, (p + 3 * o + m), 1) = "1" Then picField.Line (167, 103)-(190, 103), vbBlack: picField.Line (167, 44)-(190, 44), vbBlack: GoTo m2190 'справа горизонтальные черточки
m3755: If Mid(map, (p + 4 * o + m), 1) = "1" Then picField.Line (167, 87)-(190, 87), vbBlack: picField.Line (167, 52)-(190, 52), vbBlack: GoTo m2190 'справа горизонтальные черточки
m3760: picField.Line (175, 79)-(175, 56), vbBlack 'справа вертикаль посередине
            If Mid(map, (p + 4 * o + 2 * m), 1) = "0" Then picField.Line -(190, 56), vbBlack: picField.Line (175, 79)-(190, 79), vbBlack: picField.Line (175, 79)-(168, 79), vbBlack: picField.Line (175, 56)-(168, 56), vbBlack: GoTo m2190 'горизонтальные черточки от вертикали
m3770: picField.Line -(189, 54), vbBlack: picField.Line (175, 79)-(190, 84), vbBlack: picField.Line (175, 79)-(167, 76), vbBlack: picField.Line (175, 56)-(168, 57), vbBlack: GoTo m2190 'горизонтальные черточки от вертикали
m3800: If Mid(map, (p + 4 * o + n), 1) = "1" Then picField.Line (104, 87)-(89, 87), vbBlack: picField.Line (104, 52)-(89, 52), vbBlack: GoTo m2230 ' 1-верх, 2-низ горизонтали
m3805: If Mid(map, (p + 5 * o + n), 1) = "1" Then picField.Line (104, 79)-(89, 79), vbBlack: picField.Line (104, 56)-(89, 56), vbBlack: GoTo m2230 ' 1-верх, 2-низ горизонтали
m3810: picField.Line (100, 72)-(100, 60), vbBlack ' вертикаль
       If Mid(map, (p + 5 * o + 2 * n), 1) = "1" Then picField.Line (88, 77)-(103, 71), vbBlack: picField.Line (88, 57)-(103, 60), vbBlack: GoTo m2230  '1-верх, 2-низ горизонтали
m3820: picField.Line (88, 72)-(103, 72), vbBlack: picField.Line (88, 60)-(103, 60), vbBlack: GoTo m2230 ' 1-верх, 2-низ горизонтали
m3850: If Mid(map, (p + 4 * o + m), 1) = "1" Then picField.Line (151, 87)-(166, 87), vbBlack: picField.Line (151, 52)-(166, 52), vbBlack: GoTo m2250 ' справа в середине две горизонтали
m3855: If Mid(map, (p + 5 * o + m), 1) = "1" Then picField.Line (151, 79)-(166, 79), vbBlack: picField.Line (151, 56)-(166, 56), vbBlack: GoTo m2250 ' справа в середине две горизонтали
m3860: picField.Line (155, 72)-(155, 60), vbBlack ' вертикаль коридорная справа
       If Mid(map, (p + 5 * o + 2 * m), 1) = "1" Then picField.Line (167, 77)-(152, 71), vbBlack: picField.Line (167, 57)-(152, 60), vbBlack: GoTo m2250 ' две черточки к вертикали справа
m3870: picField.Line (167, 72)-(152, 72), vbBlack: picField.Line (167, 60)-(152, 60), vbBlack: GoTo m2250 'две черточки к вертикали справа
m3900: If Mid(map, (p + 5 * o + n), 1) = "1" Then picField.Line (114, 77)-(104, 77), vbBlack: picField.Line (114, 57)-(104, 57), vbBlack: GoTo m2280 '=5 слева стена 1-верх, 2-вниз===
m3910: If Mid(map, (p + 6 * o + n), 1) = "1" Then picField.Line (114, 71)-(104, 71), vbBlack: picField.Line (114, 60)-(104, 60), vbBlack: GoTo m2280 '=6 слева стенка=1-верх, 2-вниз=
m3920: picField.Line (111, 69)-(111, 62), vbBlack ' вертикаль слева
       If Mid(map, (p + 6 * o + 2 * n), 1) = "1" Then picField.Line (104, 61)-(114, 63), vbBlack: picField.Line (104, 72)-(114, 68), vbBlack: GoTo m2280 'две черты к вертикали слева
m3930: picField.Line (104, 63)-(114, 63), vbBlack: picField.Line (104, 69)-(114, 69), vbBlack: GoTo m2280 'две черты к вертикали слева
m3950: If Mid(map, (p + 5 * o + m), 1) = "1" Then picField.Line (141, 77)-(151, 77), vbBlack: picField.Line (141, 57)-(151, 57), vbBlack: GoTo m2300 'две черточки справа горизонтали
m3960: If Mid(map, (p + 6 * o + m), 1) = "1" Then picField.Line (141, 71)-(151, 71), vbBlack: picField.Line (141, 60)-(151, 60), vbBlack: GoTo m2300 'две черточки справа горизонтали
m3970: picField.Line (144, 69)-(144, 62), vbBlack ' справа вертикаль коридорная
            If Mid(map, (p + 6 * o + 2 * m), 1) = "1" Then picField.Line (151, 61)-(141, 63), vbBlack: picField.Line (151, 72)-(141, 68), vbBlack: GoTo m2300 'две черточки справа горизонтали
m3980: picField.Line (151, 63)-(141, 63), vbBlack: picField.Line (151, 69)-(141, 69), vbBlack: GoTo m2300 'две черточки справа горизонтали
m4000: If Mid(map, (p + 6 * o + n), 1) = "1" Then picField.Line (120, 71)-(112, 71), vbBlack: picField.Line (120, 61)-(112, 61), vbBlack: GoTo m2340 '================
m4010: picField.Line (120, 68)-(114, 68), vbBlack: picField.Line (120, 63)-(114, 63), vbBlack: GoTo m2340
m4050: If Mid(map, (p + 6 * o + m), 1) = "1" Then picField.Line (135, 71)-(141, 71), vbBlack: picField.Line (135, 61)-(141, 61), vbBlack: GoTo m2360
m4060: picField.Line (135, 68)-(141, 68), vbBlack: picField.Line (135, 63)-(141, 63), vbBlack: GoTo m2360
m5000: 'picField.Line (0, 0)-(100, 100)
End Sub
 
Sub GSB5060() 'подпрограмма для поворота
    If o = 0 Then o = -20
    If Abs(o) = 21 Then o = -1
    If Abs(o) = 2 Then o = 20
    If Abs(o) = 19 Then o = 1
End Sub
 
 
Private Sub cmdBit_Click() 'кнопка включения и выключения карты на экране
   If picField.Visible = True Then
       cmdBit.Caption = "L&abyrith"
        picField.Visible = False
        Call mapOutput
    Else
        cmdBit.Caption = "M&ap"
        picField.Visible = True
        Call Basic
    End If
End Sub
 
'==============================================================
Sub mapOutput() 'подпрограмма вывода карты на экран
    chet = chet - 60 'd(y)
    lblInfo2.Caption = chet
    For i = 1 To Len(map) '400
        If Mid(map, i, 1) = "1" Then
            imgCell(i).Picture = ColImg.ListImages("blue+").Picture
        Else
            imgCell(i).Picture = ColImg.ListImages("white").Picture
        End If
    Next i
            imgCell(p).Picture = ColImg.ListImages("man").Picture
            imgCell(z).Picture = ColImg.ListImages("ext2").Picture
End Sub
 
Sub MapMake() 'подпрограмма формирования карты
    arr(1) = "1111111111111111111110100100011100010101101101010001101000011001011111001000111111000000000100100011111111011011101110111100010010001101000110010001001010000111110101000110011100011001001100101100010111111010101000011111110110100011110100011100001010001101110110011010111010010101110110111010001101011000111000111110010110101010111010001101100000000000101000011011010101100011011111111111111111111111"
    plus(1) = "022024033039047114135199237268" 'координаты конечного пути (022, 024, 033, 039, 047, 114...)
    arr(2) = "1111111111111111111110000001001110001001110111001001001000111001011000111111010111000110100001000001100100111101000101011110100001011011001110000110110010011001101101011111011000111000110001000000110110100101000101100101101111001010001100011001000110101010101111000111001011100011100100101111100010111111101000000010000110001111110101110111101010000000110101011010001010100100000111111111111111111111"
    plus(2) = "148165167205269288359362373282"
    arr(3) = "1111111111111111111111000101011000100111100100010010101100111011110010001101100110100110101000001011111010100011111010011000001011101001001110101010010010110101110011110001000000011110000010110111011110111110100000100001100001000011111111011101010111100001010111110000001011000001110001011010011111011001111100111101000111000000101001011011110110100000110000011001001011100111010111111111111111111111"
    plus(3) = "036079082116216293315333365379"
    arr(4) = "1111111111111111111110101100000101000001100000011100000110111111011101101101111110010010000010010001101110110111101111011010100011000000010110001101000101010001101001110111001001011111000001011011110110001110110000000111101000101110111010011111100010111010101110001101100000100001111000001101101110111001011111110000100110111000110101111101101000100100000001011000100100010111000111111111111111111111"
    plus(4) = "022039097083088147199222262288"
    
    lblInfo.Caption = "Уровень " & ver
    Randomize Time
    map = arr(ver)
    way = plus(ver) 'переменная - y$
        If ver = 1 Then p = 342 + Int(Rnd * 3) * 3
        If ver = 2 Then p = 35 + Int(Rnd * 3) * 22
        If ver = 3 Then p = 84 + Int(Rnd * 3) * 40
        If ver = 4 Then p = 349 + Int(Rnd * 3) * 4
 
    o = 1: z = (Int(Rnd * 10)) * 3
    z = Val(Mid(way, z + 1, 3)) 'LET z=VAL(y$(z+1 to z+3))
    tmrTimer.Interval = 0
    chet = 1060
End Sub
 
Private Sub tmrTimer_Timer() 'первичная заставка
    picField.PSet (50, 60), vbRed 'нарисовать звено
    picField.PSet (0, 0), vbBlue 'нарисовать звено
    picField.Line (0, 0)-(255, 175), vbGreen  'нарисовать звено
    picField.Line (50, 10)-(120, 100), vbYellow, B 'нарисовать звено
    picField.Circle (80, 60), 50, vbCyan
    picField.Circle (80, 60), 40, vbBlack, -1, -5
    picField.Circle (80, 60), 40, vbRed, -5, -1
    picField.FillColor = vbRed
    picField.Line -(10, 50), vbGreen  'нарисовать звено
    picField.PSet (65, 150), vbBlack 'точка
    'picField.Line -(65, 200), vbBlue 'точка
    picField.ForeColor = 128
    picField.FontBold = True
    picField.FontUnderline = True
    picField.FontSize = 24
    picField.Print "Labyrinth"
    picField.FontBold = False
    picField.FontUnderline = False
End Sub

Option Explicit
Dim a As Byte, b As Byte, c As Byte
Dim i  As Integer, j As Integer
Dim x As Integer, y As Integer
Dim cell(-1 To 10, -1 To 10) As String 'игровое поле
Dim copy(-1 To 10, -1 To 10) As String 'копия расположения мин
Dim cnt As Byte
Dim MinesMax As Byte
 
 
Private Sub Form_Load()
    Call NewCls
End Sub
 
Sub NewCls()
'начальная заставка
    lblLabel1.Caption = "Сапер v1.6"
    Form1.Caption = lblLabel1.Caption
    lblLabel2.Caption = Slider.Value & " мин"
    Randomize
    c = Int((10 * Rnd) + 1)      'рандомное определение image
    imgFon.Visible = True
    imgFon.Picture = ColImg2.ListImages("img" & c).Picture
'For i = 0 To 99
'    imgImage(i).Picture = ColImg.ListImages("empty").Picture
'Next
End Sub
 
Private Sub MinesGame_Click()
    Slider.Visible = True
End Sub
Private Sub Slider_Change()
    lblLabel2.Caption = Slider.Value & " мин"
End Sub
Private Sub ExitGame_Click()
    End
End Sub
 
 
Private Sub newGame_Click()
    MinesMax = Slider.Value
    Slider.Visible = False
    imgFon.Visible = False
For x = 0 To 9
For y = 0 To 9
    cell(x, y) = ""
    copy(x, y) = ""
Next y, x
For i = 0 To 99
    imgImage(i).Picture = ColImg.ListImages("frn").Picture  'LoadPicture("frn.bmp")
Next
    Call MinesField
    Call numeric
    lblLabel1.Caption = "Go!!!"
End Sub
 
Private Sub imgImage_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    i = Index
    a = Int(i / 10)
    b = ((i / 10) - a) * 10
 
'открывает ячеку и выводит на экран изображение
If Button = 1 Then Call InfoScreen
 
If Button = 2 And copy(a, b) <> "flag" Then 'нажата правая кнопка мышки
    copy(a, b) = "flag"
    imgImage(i).Picture = ColImg.ListImages("flag").Picture     'LoadPicture("flag.bmp")
Debug.Print cell(a, b), i, copy(a, b)
    For x = 0 To 9
    For y = 0 To 9
    If copy(x, y) = "bomb" Then Exit Sub
    Next y
    Next x
            MsgBox "УРА! ПОБЕДА"
            Call NewCls
End If
End Sub
 
'выводит изображения на экран
'===============================================================
Sub InfoScreen()
    Select Case cell(a, b)
    Case Is = ""
        imgImage(i).Picture = ColImg.ListImages("empty").Picture 'LoadPicture("empty.bmp")
    Case Is = 1
        imgImage(i).Picture = ColImg.ListImages("one").Picture 'LoadPicture("1.bmp")
    Case Is = 2
        imgImage(i).Picture = ColImg.ListImages("two").Picture 'LoadPicture("2.bmp")
    Case Is = 3
        imgImage(i).Picture = ColImg.ListImages("three").Picture 'LoadPicture("3.bmp")
    Case Is = 4
        imgImage(i).Picture = ColImg.ListImages("four").Picture 'LoadPicture("4.bmp")
    Case Is = 5
        imgImage(i).Picture = ColImg.ListImages("five").Picture 'LoadPicture("5.bmp")
    Case Is = 6
        imgImage(i).Picture = ColImg.ListImages("six").Picture 'LoadPicture("6.bmp")
    Case Is = 7
        imgImage(i).Picture = ColImg.ListImages("seven").Picture 'LoadPicture("7.bmp")
    Case Is = 8
        imgImage(i).Picture = ColImg.ListImages("eight").Picture 'LoadPicture("8.bmp")
    Case Is = "bomb"
        imgImage(i).Picture = ColImg.ListImages("bomb").Picture 'LoadPicture("bomb.bmp")
        For x = 0 To 9
        For y = 0 To 9
            If copy(x, y) = "bomb" Then
            imgImage(x * 10 + y).Picture = ColImg.ListImages("bomb").Picture 'LoadPicture("bomb.bmp")
            End If
        Next y
        Next x
        MsgBox "Boooom!"
        Call NewCls
    End Select
End Sub
 
'генерирует бомбы на поле
'===============================================================
Sub MinesField()
Dim mine As Byte
mine = 0
Do While (mine < MinesMax) 'наше количество мин
    Randomize
    x = Int((10 * Rnd) + 0)      'рандомное определение строки для мины
    y = Int((10 * Rnd) + 0)      'рандомное определение столбца для мины
    If cell(x, y) = "" Then      'если в ячейке ничего нет
       cell(x, y) = "bomb"      '  "ставим" в эту ячейку Бомбу
        copy(x, y) = "bomb"
        mine = mine + 1 'увеличиваем счетчик бомб на 1
    End If
Loop 'следующая итерация цикла
End Sub
 
'геерирует цифру о кол-во бомб вокруг
Sub numeric()
For i = 0 To 9 'запускаем цикл по каждой ячейки нашего минного поля
For j = 0 To 9 'столбцы и строки
    cnt = 0 'счетчик мин равный нулю
    If cell(i, j) = "" Then 'проверяем ячейки вокруг искомой
        For x = i - 1 To i + 1
        For y = j - 1 To j + 1
            'если вокруг искомой ячейки есть мина - наращиваем счетчик
            If cell(x, y) = "bomb" And x <> -1 And y <> -1 Then cnt = cnt + 1
        Next y
        Next x
    End If
    If cnt <> 0 Then
        cell(i, j) = cnt 'если счетчик не равен нулю - ставим цифру в ячейку
    End If
Next j
Next i
End Sub

Option Explicit
Dim K As Integer 'ячейка поля пустая или нет
Dim K1(24, 24) As Integer 'массив размера поля
Dim X As Integer ' координата поля Х
Dim Y As Integer ' координата поля Y
Dim X1(2048) As Integer 'массив пути змейки
Dim Y1(2048) As Integer 'массив пути змейки
Dim R As Byte 'генератор чисел
Dim L As Byte 'длина змейки
Dim NX As Integer ' шаг змейки по горизонтали
Dim NY As Integer 'шаг змейки по вертикали
Dim Z As Integer 'переменная для прироста змейки
Dim I As Integer 'шаги змейки
Dim a As Integer, b As Integer, c As Integer 'вспомогательные
     
Private Sub Form_Load()
'    picField.Scale (0, 0)-(32, 24) 'поле размером 32х24 точки
'    picField.DrawWidth = 10 'толщина точки
'    picField.ScaleMode = 0 'пользовательский тип
    For I = 1 To 576
        imgcell(I).Picture = ColImg.ListImages("white").Picture 'Картинка загружается в объект Image
    Next I
        For I = 0 To 6
        X1(I) = 12
        Y1(I) = 24
        Next I
    L = 6
    NY = -1
End Sub
 
Private Sub cmdPusk_Click()
    tmrTimer.Interval = 500
End Sub
 
 
Private Sub tmrTimer_Timer()
X1(I) = X1(I - 1) + NX
Y1(I) = Y1(I - 1) + NY
K = K1(X1(I), Y1(I)) 'передает значение ячейки поля
    If X1(I) > 24 Or X1(I) < 1 Or Y1(I) > 24 Or Y1(I) < 1 Or K > 9 Then 'End 'проверка столкновения со стенкой и натолкновения на бомбу К
            MsgBox "Game Over"
            End
    End If
    'On Error Resume Next ' Если нет файла с данными
    'picField.PSet (X1(I - 1), Y1(I - 1)), vbRed 'нарисовать звено
    imgcell(X1(I - 1) + Y1(I - 1) * 24 - 24).Picture = ColImg.ListImages("green").Picture 'нарисовать звено
                    K1(X1(I - 1), Y1(I - 1)) = 11 'вставить в звено цифру больше 9, чтобы не налазил на себя
    'picField.PSet (X1(I - L), Y1(I - L)), vbWhite 'затереть хвост белым
    imgcell(X1(I - L) + Y1(I - L) * 24 - 24).Picture = ColImg.ListImages("white").Picture 'нарисовать звено
                    K1(X1(I - L), Y1(I - L)) = 0 'затереть хвост нулем
    'picField.PSet (X1(I), Y1(I)), vbBlue 'голова змейки
    imgcell(X1(I) + Y1(I) * 24 - 24).Picture = ColImg.ListImages("blue").Picture 'нарисовать звено
          If K Then L = L + K 'O = O + К * 10: 'если К не ноль то тогда ДА, удлинить змейку
                lblHelp.Caption = L
                lblInfo.Caption = I
    If Rnd(1) > 0.95 Then 'генерирует место положение и кол-во приращения
        X = Number(22): Y = Number(22) 'координаты
        Z = Number(9) 'приращение
        K1(X, Y) = Z 'поместит на поле
        'picField.PSet (X, Y), vbGreen 'высветить объект
        Select Case Z
            Case 1
            imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("n001").Picture 'нарисовать звено цифру
            Case 2
            imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("n002").Picture 'нарисовать звено цифру
            Case 3
            imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("n003").Picture 'нарисовать звено цифру
            Case 4
            imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("n004").Picture 'нарисовать звено цифру
            Case 5
            imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("n005").Picture 'нарисовать звено цифру
            Case 6
            imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("n006").Picture 'нарисовать звено цифру
            Case 7
            imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("n007").Picture 'нарисовать звено цифру
            Case 8
            imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("n008").Picture 'нарисовать звено цифру
            Case 9
            imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("n009").Picture 'нарисовать звено цифру
        'imgcell(X * Y).Picture = LoadPicture("004.gif") 'нарисовать звено
        End Select
    End If
    If Rnd(1) > 0.98 Then 'генерируется бомба
        X = Number(22): Y = Number(22) ' координаты в пределах поля
        K1(X, Y) = 10 'идентификатор цифра 10
        'picField.PSet (X, Y), vbBlack 'цвет черный
        imgcell(X + Y * 24 - 24).Picture = ColImg.ListImages("black").Picture 'нарисовать звено цифру
    End If
I = I + 1
End Sub
 
Private Sub picField_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
    Case 38      'вверх
        NX = 0
        NY = -1
    Case 40      'вниз
        NX = 0
        NY = 1
    Case 37      'влево
        NX = -1
        NY = 0
    Case 39      'вправо
        NX = 1
        NY = 0
    Case 27      'ESC
        End
    Case 113     'F2-игра
        'Форма_Змейка.Enabled = True
        'Форма_Змейка.Form_Load
        'ИнформационнаяФорма.Hide
End Select
End Sub
 
'== генератор случайных чисел для поля ==
Private Function Number(a As Byte) As Integer
      ' Загадать число от 1 до A
      Randomize
      Number = Int(Rnd(1) * a) + 1
End Function