API tools faq
paste
vladikcomper

S1 Hacking Studio 2.0 - Source Code

vladikcomper
May 10th, 2014
657
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VisualBasic 45.79 KB | None | 0 0
raw download clone embed print report
  1. ' =====================================================================
  2. ' S1 Hacking Studio - Main Core
  3. ' Версия 2.0
  4. ' =====================================================================
  5. ' (c) 2010, Vladikcomper
  6. ' =====================================================================
  7.  
  8. Option Explicit
  9.  
  10. Private Declare Function DrawTransparent Lib "msimg32" Alias "TransparentBlt" _
  11.  (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, _
  12.   ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, _
  13.   ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, _
  14.   ByVal nHeightSrc As Long, ByVal crTransparent As Long) As Long
  15.  
  16. Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, _
  17.   ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, _
  18.   ByVal nHeight As Long, ByVal hSrcDC As Long, _
  19.   ByVal xSrc As Long, ByVal ySrc As Long, _
  20.   ByVal hSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  21. Private Const SRCCOPY = &HCC0020
  22.  
  23. Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
  24.  (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
  25.   ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) _
  26.   As Long
  27. Const SW_SHOWNORMAL = 1
  28.  
  29.  
  30. ' -------------------------------
  31. ' Переменные менюшечного модуля
  32. ' -------------------------------
  33.  
  34. Private Type clsMenuItem
  35.  strId As Byte
  36.  frmId As Byte
  37.  Xstart As Integer
  38.  Xend As Integer
  39. End Type
  40.  
  41. Dim mnuStrings() As String      ' Массив надписей для меню
  42. Dim mnuCommand() As String      ' Массив команд для субменю
  43. Dim mnuItem() As clsMenuItem    ' Массив элементов меню
  44. Dim mnuSubItem() As clsMenuItem ' Массив элементов субменю
  45. Dim mnuSubDisplay As Boolean    ' Флаг отображения субменю
  46.  
  47. Dim mnuCurrentItem As Byte      ' Текущий пункт меню
  48. Dim mnuCurrentSubItem As Byte   ' Текущий пункт субменю
  49. Dim mnuSelectedItem As Byte     ' Выделенный пункт меню
  50. Dim mnuSelectedSubItem As Byte  ' Выделенный пункт субменю
  51.  
  52. Dim mnuItemYstart As Integer
  53. Dim mnuItemYend As Integer
  54. Dim mnuSubItemYstart As Integer
  55. Dim mnuSubItemYend As Integer
  56.  
  57. Const mnuItemCount% = 5         ' Количество пунктов меню
  58. Const mnuItemStartUp% = 5       ' Вкладка по умолчанке при запуске
  59. Const mnuLeft% = 10             ' Отступ слева
  60. Const mnuBottom% = 0            ' Отступ снизу
  61. Const mnuItemSize% = 10         ' Размер шрифта для элемента меню
  62. Const mnuSubItemSize% = 9       ' Размер шрифта для субменю
  63. Const mnuActColor As Long = &HEBE0D1
  64. Const mnuSelColor As Long = &HDBD0BF
  65.  
  66.  
  67. ' ------------------------------
  68. ' Переменные текстового модуля
  69. ' ------------------------------
  70.  
  71. Dim ttxData(23, 20) As Byte              ' Массив символов Левел Селекта
  72. Dim ttxPointX As Byte, ttxPointY As Byte ' Координаты курсора
  73.  
  74.  
  75. ' ##################################################################### '
  76. ' #                * ОСНОВНЫЕ ПРОЦЕДУРЫ И ФУНКЦИИ *                   # '
  77. ' ##################################################################### '
  78.  
  79. ' =====================================================================
  80. ' Инициализация программы
  81. ' =====================================================================
  82.  
  83. Sub Init()
  84. ' On Error GoTo bug
  85.  
  86.  Dim F%, St$
  87.  F = FreeFile
  88.  
  89.  ' Подготовка формы
  90. Dim obj As Control
  91.  For Each obj In lbl: obj.BackStyle = 0: Next
  92.  For Each obj In frm: obj.BackColor = Me.BackColor: Next
  93.  Set obj = Nothing
  94.  frm(7).BackColor = 0
  95.  
  96.  ' Проверка папок
  97. If Dir(App.path & "\SourceCode", vbDirectory) = "" Then _
  98.     Err.Raise 1003, , "Отсутсвует папка SourceCode."
  99.    
  100.  ' Читаем группы музыки
  101. Open App.path & "\Data\musiclist.dat" For Input As #F
  102.   Dim i As Byte
  103.   Do Until EOF(F)
  104.    Line Input #F, St
  105.    lstManagerGroup.AddItem St
  106.    For i = 0 To cmbMusGroup.UBound
  107.     cmbMusGroup(i).AddItem St
  108.    Next i
  109.   Loop
  110.  Close #F
  111.  lstManagerGroup.ListIndex = 0
  112.  
  113.  ' Загружаем текст меню выбора уровней
  114. Open App.path & "\SourceCode\misc\menutext.bin" For Binary As #F
  115.   Get #F, , ttxData()
  116.  Close #F
  117.  
  118.  Exit Sub
  119. bug:
  120.  MsgBox "Произошла ошибка при запуске: " & Err.Description, vbCritical, _
  121.         "Вот невезуха!"
  122.  End
  123. End Sub
  124.  
  125.  
  126. ' =====================================================================
  127. ' Сохранение настроек программы
  128. ' =====================================================================
  129.  
  130. Sub SaveData()
  131.  On Error GoTo bug
  132.  
  133. ' -----------------------------------------
  134. ' Сохранение конфигурации в Data\hack.bin
  135. ' -----------------------------------------
  136.  
  137.  Dim F%, i%: F = FreeFile
  138.  Open App.path & "\Data\hack.bin" For Binary As #F
  139.  
  140.  Dim tmpString256 As String * 256   ' Шаблон строки 256 символов
  141. Dim tmpString64 As String * 64     ' Шаблон строки 64 символа
  142. Dim tmpString16 As String * 16     ' Шаблон строки 16 символов
  143. Dim tmpBoolean As Boolean
  144.  Dim tmpByte As Byte
  145.  
  146.  ' [PUT] Главные параметры
  147. For i = 0 To 2
  148.   tmpByte = chkOption(i).Value
  149.   Put #F, , tmpByte
  150.  Next i
  151.  tmpByte = &HFF
  152.  For i = 1 To 5: Put #F, , tmpByte: Next ' пропустить 5 байтов
  153.  
  154.  ' [PUT] Твикинг
  155. For i = 0 To 4
  156.   tmpByte = chkSonic(i).Value ' Соник
  157.  Put #F, , tmpByte
  158.  Next i
  159.  For i = 0 To 5
  160.   tmpByte = Abs(vsBoss(i)) ' Удары у боссов
  161.  Put #F, , tmpByte
  162.  Next i
  163.  For i = 0 To 1
  164.   tmpByte = chkArt(i).Value ' Замена арта
  165.  Put #F, , tmpByte
  166.  Next i
  167.  For i = 1 To 3: Put #F, , tmpByte: Next ' пропустить 3 байта
  168. Dim obj As Control
  169.  For Each obj In optArtMon: Put #F, , CByte(IIf(obj.Value, 1, 0)): Next
  170.  For Each obj In optArtHUD: Put #F, , CByte(IIf(obj.Value, 1, 0)): Next
  171.  
  172.  tmpByte = &HFF
  173.  Put #F, , tmpByte ' пропустить 1 байт
  174.  
  175.  ' [PUT] Названия зон
  176. For i = 0 To 1
  177.   tmpByte = chkZoneAct(i).Value ' Флажки
  178.  Put #F, , tmpByte
  179.  Next
  180.  For i = 0 To 8
  181.   tmpString16 = txtZone(i) ' Названия
  182.  Put #F, , tmpString16
  183.  Next
  184.  
  185.  ' [PUT] Порядок уровней
  186. For i = 0 To 19
  187.   tmpByte = lstLvlOrder.ItemData(i)
  188.   Put #F, , tmpByte
  189.  Next i
  190.  tmpByte = &HFF
  191.  For i = 1 To 12: Put #F, , tmpByte: Next ' пропустить 12 байт
  192.  
  193.  ' [PUT] Настройки музыки
  194. For i = 0 To cmbMusGroup.UBound
  195.   tmpString64 = cmbMusGroup(i) & "_" & Replace(cmbMusList(i), " ", "_")
  196.   Put #F, , tmpString64
  197.  Next i
  198.  
  199.  ' [PUT] Каталог компиляции
  200. tmpString256 = txtCompPath
  201.  Put #F, , tmpString256
  202.  
  203.  Close #F
  204.  
  205.  
  206. ' ---------------------------------------------------------
  207. ' Генерация файла config.asm с основными настройками хака
  208. ' ---------------------------------------------------------
  209.  
  210.  If chkOption(1).Value = 1 Then GoTo SkipConfig
  211.  
  212.  F = FreeFile
  213.  Open App.path & "\SourceCode\config.asm" For Output As #F
  214.  
  215.  Dim ArrTxt() As Byte
  216.  ArrTxt() = LoadResData(101, "TXT_CHUNKS")
  217.  For i = 0 To 501: Print #F, Chr(ArrTxt(i));: Next
  218.  
  219.  Print #F, "_DEBUG_" & Chr(9) & Chr(9) & "equ " & chkSonic(4).Value & vbCrLf
  220.  
  221.  Print #F, "; Sonic Tweaking"
  222.  Dim ArrStr(5) As String
  223.  ArrStr(0) = "_SPINDASH_":      ArrStr(1) = "_JUMPDASH_"
  224.  ArrStr(2) = "_SPEEDCAPFIX_":   ArrStr(3) = "_SPIKEBUGFIX_"
  225.  For i = 0 To 3: Print #F, ArrStr(i) & Chr(9) & "equ " & chkSonic(i): Next
  226.  Print #F, vbCrLf
  227.  
  228.  Print #F, "; Boss Hits"
  229.  ArrStr(0) = "GHZ": ArrStr(1) = "MZ":  ArrStr(2) = "SYZ"
  230.  ArrStr(3) = "LZ":  ArrStr(4) = "SLZ": ArrStr(5) = "FZ"
  231.  For i = 0 To 5
  232.   Print #F, "var_BHits_" & ArrStr(i) & Chr(9) & "= " & Abs(vsBoss(i).Value)
  233.  Next
  234.  
  235.  Close #F
  236.  
  237. SkipConfig:
  238.  
  239.  
  240. ' ----------------------------
  241. ' Применения порядка уровней
  242. ' ----------------------------
  243.  
  244.  F = FreeFile
  245.  Open App.path & "\SourceCode\misc\lvl_ord.bin" For Binary As #F
  246.  Dim ii%, iii%, NextLevel%, out%
  247.  For i = 0 To 5
  248.   For ii = 0 To IIf(i = 1, 3, 2)
  249.    Select Case i * 100 + ii ' Определить Id зоны в списке
  250.    Case 103:  out = 17     ' - Scrap Brain 3 (LZ 4)
  251.    Case 502:  out = 18     ' - Final Zone
  252.    Case Else: out = i * 3 + ii
  253.    End Select
  254.    For iii = 0 To 19        ' Найти позицию в списке по Id
  255.    If lstLvlOrder.ItemData(iii) = out Then Exit For
  256.    Next iii
  257.    If iii = 19 Then
  258.     NextLevel = 0
  259.    Else: NextLevel = lstLvlOrder.ItemData(iii + 1)
  260.    End If
  261.    Select Case NextLevel    ' Определить номер уровня по Id
  262.    Case 0:    out = 0
  263.     Case 18:   out = &H205  ' $0502 - Final Zone
  264.    Case 17:   out = &H301  ' $0103 - Scrap Brain 3 (LZ 4)
  265.    Case &H80: out = 0
  266.     Case Else: out = (NextLevel Mod 3) * &H100 + NextLevel \ 3
  267.    End Select
  268.    Put #F, , out
  269.   Next ii
  270.   out = 0
  271.   If ii < 4 Then Put #F, , out ' Пропустить 2 байта
  272. Next i
  273.  Close #F
  274.  
  275.  
  276. ' ---------------------------------------
  277. ' Сохранение текста меню выбора уровней
  278. ' ---------------------------------------
  279.  
  280.  Open App.path & "\SourceCode\misc\menutext.bin" For Binary As #F
  281.   Put #F, , ttxData()
  282.  Close #F
  283.  
  284.  
  285. ' ---------------------
  286. ' Генерация build.bat
  287. ' ---------------------
  288.  
  289.  Open App.path & "\SourceCode\build.bat" For Output As #F
  290.  ArrTxt() = LoadResData(102, "TXT_CHUNKS")
  291.  For i = 0 To 124: Print #F, Chr(ArrTxt(i));: Next
  292.  If chkOption(0).Value = 0 Then Print #F, "_exec\rompad s1built.bin 255 0"
  293.  Print #F, "_exec\fixheadr s1built.bin"
  294.  Print #F, "copy s1built.bin " & Chr(34) & txtCompPath & Chr(34)
  295.  Print #F, "pause"
  296.  Close #F
  297.  
  298.  
  299. ' ------------------------------------------------
  300. ' Замена музыки в дизасембле на выбранную в S1HS
  301. ' ------------------------------------------------
  302.  
  303.  For i = &H81 To &H93 ' песни $81-$93
  304.  If Dir(App.path & "\SourceCode\sound\music" & Hex$(i) & ".bin") <> "" Then _
  305.     Kill App.path & "\SourceCode\sound\music" & Hex$(i) & ".bin"
  306.   FileCopy App.path & "\Music\" & cmbMusGroup(i - &H81) & "_" & _
  307.     Replace(cmbMusList(i - &H81), " ", "_"), _
  308.     App.path & "\SourceCode\sound\music" & Hex$(i) & ".bin"
  309.  Next i
  310.  Open App.path & "\Data\musicset.dat" For Input As #F ' прочая музыка
  311.  Dim St$
  312.   Line Input #F, St
  313.   Dim arr() As String
  314.   arr() = Split(St, " ")
  315.   For i = 0 To UBound(arr)
  316.    If Dir(App.path & "\SourceCode\sound\music" & arr(i) & ".bin") <> "" Then _
  317.     Kill App.path & "\SourceCode\sound\music" & arr(i) & ".bin"
  318.    FileCopy App.path & "\Music\" & cmbMusGroup(i + 19) & "_" & _
  319.      Replace(cmbMusList(i + 19), " ", "_"), _
  320.     App.path & "\SourceCode\sound\music" & arr(i) & ".bin"
  321.   Next i
  322.  Close #F
  323.  
  324.  
  325. ' --------------------------
  326. ' Замена арта в дизасембле
  327. ' --------------------------
  328.  
  329.  If chkArt(0).Value = 1 Then ' Арт Мониторов
  330.  If Dir(App.path & "\SourceCode\artnem\monitors.bin") <> "" Then _
  331.     Kill App.path & "\SourceCode\artnem\monitors.bin"
  332.   If optArtMon(0).Value = True Then ' Sonic 1
  333.   FileCopy App.path & "\Data\art_Monitors_S1.bin", _
  334.             App.path & "\SourceCode\artnem\monitors.bin"
  335.   Else                               ' Sonic 3
  336.   FileCopy App.path & "\Data\art_Monitors_S3.bin", _
  337.             App.path & "\SourceCode\artnem\monitors.bin"
  338.   End If
  339.  End If
  340.  If chkArt(1).Value = 1 Then ' Арт HUD'а
  341.  If Dir(App.path & "\SourceCode\artnem\hud.bin") <> "" Then _
  342.     Kill App.path & "\SourceCode\artnem\hud.bin"
  343.   If Dir(App.path & "\SourceCode\artunc\hud.bin") <> "" Then _
  344.     Kill App.path & "\SourceCode\artunc\hud.bin"
  345.   If optArtHUD(0).Value = True Then     ' Sonic 1
  346.   FileCopy App.path & "\Data\art_HUD1_S1.bin", _
  347.             App.path & "\SourceCode\artnem\hud.bin"
  348.    FileCopy App.path & "\Data\art_HUD2_S1.bin", _
  349.             App.path & "\SourceCode\artunc\hud.bin"
  350.   ElseIf optArtHUD(1).Value = True Then ' Sonic 2
  351.   FileCopy App.path & "\Data\art_HUD1_S2.bin", _
  352.             App.path & "\SourceCode\artnem\hud.bin"
  353.    FileCopy App.path & "\Data\art_HUD2_S2.bin", _
  354.             App.path & "\SourceCode\artunc\hud.bin"
  355.   Else                                   ' Sonic 3
  356.   FileCopy App.path & "\Data\art_HUD1_S3.bin", _
  357.             App.path & "\SourceCode\artnem\hud.bin"
  358.    FileCopy App.path & "\Data\art_HUD2_S1.bin", _
  359.             App.path & "\SourceCode\artunc\hud.bin"
  360.   End If
  361.  End If
  362.  
  363.  
  364. ' -----------------------------------
  365. ' Генерация текстов для Title Cards
  366. ' -----------------------------------
  367.  
  368.  If chkOption(2).Value = 1 Then GoTo SkipCards
  369.  
  370.  Dim ArrM() As Byte     ' (x,4) - массив маппингов (формат Sonic 1)
  371. Dim SingleX As Byte    ' Текущая X-координата
  372. Dim SingleW As Byte    ' Ширина буквы (формат Sonic 1)
  373. Dim SingleCode As Byte ' Код буквы (формат Sonic 1)
  374. Dim RLen As Byte       ' Количество символов (без пробелов)
  375. Dim NLen As Byte       ' Количество символов (с пробелами)
  376.  
  377.  Open App.path & "\Data\ttlcards.bin" For Binary As #F
  378.  Dim D%, c As Byte
  379.  
  380.   For i = 0 To 6
  381.  
  382.    RLen = Len(Replace(txtZone(i), " ", "")) - 1
  383.    NLen = Len(txtZone(i)) - 1
  384.    ReDim ArrM(4, RLen) As Byte ' Создать массив маппингов
  385.   SingleX = 0                 ' Очистить X-координату
  386.   c = 0                       ' Счетчик символов (не реагирует на пробелы)
  387.  
  388.    ' Построение спрайтов для каждого символа
  389.   For ii = 0 To NLen
  390.     If Mid(txtZone(i), ii + 1, 1) = " " Then ' Пробел
  391.     SingleX = SingleX + 16
  392.     Else                                     ' Буквенный символ
  393.     Seek #F, (Asc(Mid(txtZone(i), ii + 1, 1)) - 64) * 2 - 1
  394.       Get #F, , SingleW        ' получить ширину (формат С1)
  395.      Get #F, , SingleCode     ' получить код (начальный тайл)
  396.     ArrM(0, c) = &HF8                      ' Y-координата
  397.     ArrM(1, c) = IIf(SingleW = &H10, 5, 1) ' Ширина спрайта
  398.     ArrM(3, c) = SingleCode                ' Номер тайла
  399.     ArrM(4, c) = SingleX                   ' X-координата
  400.     SingleX = SingleX + SingleW
  401.      c = c + 1
  402.     End If
  403.    Next ii
  404.  
  405.    ' Скоординировать буквы относительно центра спрайта
  406.   Dim RealX%, CurrX%
  407.    RealX = 256 - CInt(SingleX) \ 2
  408.    For ii = 0 To RLen
  409.     CurrX = RealX + CInt(ArrM(4, ii))
  410.     ArrM(4, ii) = IIf(CurrX > 255, CurrX - 256, CurrX)
  411.    Next ii
  412.  
  413.    ' Записать маппинги в файлы
  414.   D = FreeFile
  415.    If Dir(App.path & "\SourceCode\mapbin\ttlcards_map_" & i & ".bin") <> "" Then _
  416.      Kill App.path & "\SourceCode\mapbin\ttlcards_map_" & i & ".bin"
  417.    Open App.path & "\SourceCode\mapbin\ttlcards_map_" & i & ".bin" For Binary As #D
  418.     RLen = RLen + 1
  419.     Put #D, , RLen
  420.     Put #D, , ArrM()
  421.    Close #D
  422.  
  423.    ' Сгенерировать конфигурацию
  424.   If Dir(App.path & "\SourceCode\mapbin\ttlcards_cfg_" & i & ".bin") <> "" Then _
  425.      Kill App.path & "\SourceCode\mapbin\ttlcards_cfg_" & i & ".bin"
  426.    Open App.path & "\SourceCode\mapbin\ttlcards_cfg_" & i & ".bin" For Binary As #D
  427.     ' Zone Name
  428.    tmpByte = 0:    Put #D, , tmpByte: Put #D, , tmpByte
  429.     tmpByte = 1:    Put #D, , tmpByte
  430.     tmpByte = &H20: Put #D, , tmpByte
  431.     ' "ZONE"
  432.    Dim CurrX2 As Long
  433.     CurrX2 = ((SingleX \ 2) + &H120 - 16 * 3) - &H240
  434.     CurrX2 = &H10000 + CurrX2 ' start pos
  435.    tmpByte = CurrX2 \ &H100:   Put #D, , tmpByte
  436.     tmpByte = CurrX2 Mod &H100: Put #D, , tmpByte
  437.     CurrX2 = (SingleX \ 2) + &H120 - 16 * 3 ' end pos
  438.    If i = 6 And chkZoneAct(0).Value = 0 Then CurrX2 = CurrX2 + &H10
  439.     tmpByte = CurrX2 \ &H100:   Put #D, , tmpByte
  440.     tmpByte = CurrX2 Mod &H100: Put #D, , tmpByte
  441.     ' "ACT X"
  442.    CurrX2 = ((SingleX \ 2) - 16 * 3 + &H120) + &H18 + &H2C0 ' start pos
  443.    tmpByte = CurrX2 \ &H100:   Put #D, , tmpByte
  444.     tmpByte = CurrX2 Mod &H100: Put #D, , tmpByte
  445.     CurrX2 = CurrX2 - &H2C0 ' end pos
  446.    If i = 6 And chkZoneAct(0).Value = 0 Then CurrX2 = CurrX2 + &H2C0
  447.     tmpByte = CurrX2 \ &H100:   Put #D, , tmpByte
  448.     tmpByte = CurrX2 Mod &H100: Put #D, , tmpByte
  449.     ' Oval
  450.    CurrX2 = ((SingleX \ 2) - 16 * 3 + &H120) + &H18 + &HC0 ' start pos
  451.    tmpByte = CurrX2 \ &H100:   Put #D, , tmpByte
  452.     tmpByte = CurrX2 Mod &H100: Put #D, , tmpByte
  453.     CurrX2 = CurrX2 - &HC0 ' end pos
  454.    tmpByte = CurrX2 \ &H100:   Put #D, , tmpByte
  455.     tmpByte = CurrX2 Mod &H100: Put #D, , tmpByte
  456.    Close #D
  457.   Next i
  458.  Close #F
  459.  
  460.  
  461. ' ------------------------------------------------
  462. ' Генерация текста для экрана "SONIC HAS PASSED"
  463. ' ------------------------------------------------
  464.  
  465.  Open App.path & "\Data\ttlcards.bin" For Binary As #F
  466.   For i = 7 To 8
  467.    RLen = Len(Replace(txtZone(i), " ", "")) - 1
  468.    NLen = Len(txtZone(i)) - 1
  469.    ReDim ArrM(4, RLen) As Byte ' Создать массив маппингов
  470.   SingleX = 0
  471.    c = 0
  472.    
  473.    ' Построение спрайтов для каждого символа
  474.   For ii = 0 To NLen
  475.     If Mid(txtZone(i), ii + 1, 1) = " " Then ' Пробел
  476.     SingleX = SingleX + 16
  477.     Else                                     ' Буквенный символ
  478.     Seek #F, (Asc(Mid(txtZone(i), ii + 1, 1)) - 64) * 2 - 1
  479.       Get #F, , SingleW        ' получить ширину (формат С1)
  480.      Get #F, , SingleCode     ' получить код (начальный тайл)
  481.     ArrM(0, c) = &HF8                      ' Y-координата
  482.     ArrM(1, c) = IIf(SingleW = &H10, 5, 1) ' Ширина спрайта
  483.     ArrM(3, c) = SingleCode                ' Номер тайла
  484.     ArrM(4, c) = SingleX                   ' X-координата
  485.     SingleX = SingleX + SingleW
  486.      c = c + 1
  487.     End If
  488.    Next ii
  489.  
  490.    ' Скоординировать буквы относительно центра спрайта
  491.   RealX = 256 - (SingleX - IIf(i = 7, &H40, IIf(chkZoneAct(1).Value = 1, &H30, &H38)))
  492.    For ii = 0 To RLen
  493.     CurrX = RealX + CInt(ArrM(4, ii))
  494.     ArrM(4, ii) = IIf(CurrX > 255, CurrX - 256, CurrX)
  495.    Next ii
  496.  
  497.    ' Записать маппинги в файлы
  498.   D = FreeFile
  499.    If Dir(App.path & "\SourceCode\mapbin\sonichaspassed_map_" & i - 7 & ".bin") <> "" Then _
  500.      Kill App.path & "\SourceCode\mapbin\sonichaspassed_map_" & i - 7 & ".bin"
  501.    Open App.path & "\SourceCode\mapbin\sonichaspassed_map_" & i - 7 & ".bin" For Binary As #D
  502.     RLen = RLen + 1
  503.     Put #D, , RLen
  504.     Put #D, , ArrM()
  505.    Close #D
  506.  
  507.   Next i
  508.  
  509.   ' Сгенерировать конфигурацию для спрайта "ACT X"
  510.  If Dir(App.path & "\SourceCode\mapbin\sonichaspassed_actconf.bin") <> "" Then _
  511.     Kill App.path & "\SourceCode\mapbin\sonichaspassed_actconf.bin"
  512.   Open App.path & "\SourceCode\mapbin\sonichaspassed_actconf.bin" For Binary As #D
  513.    tmpByte = 4:    Put #D, , tmpByte ' start pos: $40C
  514.   tmpByte = &HC:  Put #D, , tmpByte
  515.    tmpByte = IIf(chkZoneAct(1).Value = 1, 1, 4):      Put #D, , tmpByte ' end pos
  516.   tmpByte = IIf(chkZoneAct(1).Value = 1, &H4C, &HC): Put #D, , tmpByte
  517.    tmpByte = 0:    Put #D, , tmpByte ' y-pos
  518.   tmpByte = &HD6: Put #D, , tmpByte
  519.   Close #D
  520.  Close #F
  521.  
  522. SkipCards:
  523.  
  524.  Exit Sub
  525. bug:
  526.  MsgBox "Произошла ошибка при сохранении: " & Err.Description, vbCritical, _
  527.         "Вот невезуха!"
  528. End Sub
  529.  
  530.  
  531. ' =====================================================================
  532. ' Загрузка настроек программы
  533. ' =====================================================================
  534.  
  535. Sub LoadData()
  536.  
  537.  On Error GoTo bug
  538.  
  539.  Dim F%, i%: F = FreeFile
  540.  Open App.path & "\Data\hack.bin" For Binary As #F
  541.  
  542.  Dim tmpString256 As String * 256   ' Шаблон строки 256 символов
  543. Dim tmpString64 As String * 64     ' Шаблон строки 64 символа
  544. Dim tmpString16 As String * 16     ' Шаблон строки 16 символов
  545. Dim tmpBoolean As Boolean
  546.  Dim tmpByte As Byte
  547.  
  548.  ' [GET] Основные параметры
  549. For i = 0 To 2
  550.   Get #F, , tmpByte
  551.   chkOption(i).Value = tmpByte
  552.   chkOption_Click i
  553.  Next
  554.  For i = 1 To 5: Get #F, , tmpByte: Next ' пропустить 5 байтов
  555.  
  556.  ' [GET] Твикинг
  557. For i = 0 To 4
  558.   Get #F, , tmpByte
  559.   chkSonic(i).Value = tmpByte ' Соник
  560. Next
  561.  For i = 0 To 5
  562.   Get #F, , tmpByte
  563.   vsBoss(i).Value = 0 - tmpByte ' Удары у боссов
  564.  vsBoss_Change i
  565.  Next
  566.  For i = 0 To 1
  567.   Get #F, , tmpByte
  568.   chkArt(i).Value = tmpByte ' Замена арта
  569.  chkArt_Click i
  570.  Next
  571.  For i = 1 To 3: Get #F, , tmpByte: Next ' пропустить 3 байта
  572. Dim obj As Control
  573.  For Each obj In optArtMon: Get #F, , tmpByte: obj.Value = IIf(tmpByte, 1, 0): Next
  574.  For Each obj In optArtHUD: Get #F, , tmpByte: obj.Value = IIf(tmpByte, 1, 0): Next
  575.  Get #F, , tmpByte ' пропустить 1 байт
  576.  
  577.  ' [GET] Названия зон
  578. For i = 0 To 1: Get #F, , tmpByte: chkZoneAct(i).Value = tmpByte: Next
  579.  For i = 0 To 8: Get #F, , tmpString16: txtZone(i) = Trim(tmpString16): Next
  580.  
  581.  ' [GET] Порядок уровней
  582. For i = 0 To 19
  583.   Get #F, , tmpByte
  584.   lstLvlOrder.AddItem tmpByte
  585.   lstLvlOrder.ItemData(lstLvlOrder.ListCount - 1) = tmpByte
  586.  Next
  587.  UpdateLevelList
  588.  For i = 1 To 12: Get #F, , tmpByte: Next ' пропустить 12 байт
  589.  
  590.  ' [GET] Настройки музыки
  591. Dim arr() As String
  592.  For i = 0 To cmbMusGroup.UBound
  593.   Get #F, , tmpString64
  594.   arr() = Split(Replace(tmpString64, "_", " ", , 1), " ")
  595.   cmbMusGroup(i) = arr(0)
  596.   cmbMusList(i) = Replace(arr(1), "_", " ")
  597.  Next i
  598.  
  599.  ' [GET] Путь компиляции
  600. Get #F, , tmpString256
  601.  txtCompPath = Trim(tmpString256)
  602.  
  603.  Close #F
  604.  
  605.  
  606.  Exit Sub
  607.  
  608. bug:
  609.  MsgBox "Произошла ошибка при загрузке данных: " & Err.Description, vbCritical, _
  610.         "Вот невезуха!"
  611.  Resume Next
  612.  End
  613. End Sub
  614.  
  615. Private Sub Form_Load()
  616.  If App.PrevInstance Then End
  617.  Init
  618.  InitGraph
  619.  InitMenu
  620.  LoadData
  621. End Sub
  622.  
  623.  
  624. ' ##################################################################### '
  625. ' #               * ФУНКЦИИ УПРАВЛЕНИЯ ГЛАВНЫМ МЕНЮ *                 # '
  626. ' ##################################################################### '
  627.  
  628. ' =====================================================================
  629. ' Инициализация меню
  630. ' =====================================================================
  631.  
  632. Sub InitMenu()
  633.  On Error GoTo bug
  634.  
  635.  Dim F%, i%, tmpStr$, strCount%: F = FreeFile
  636.  Open App.path & "\Data\menu.dat" For Input As #F
  637.  
  638.   ' Загрузка строк
  639.  Line Input #F, tmpStr
  640.   strCount = CInt(tmpStr)
  641.   ReDim mnuStrings(strCount)
  642.   For i = 0 To strCount
  643.    Line Input #F, mnuStrings(i)
  644.   Next i
  645.  
  646.   ' Загрузка команд
  647.  ReDim mnuCommand(mnuItemCount)
  648.   For i = 0 To mnuItemCount
  649.    Line Input #F, mnuCommand(i)
  650.   Next i
  651.  
  652.   ' Настройка главного меню
  653.  ReDim mnuItem(mnuItemCount)
  654.   For i = 0 To mnuItemCount
  655.    mnuItem(i).strId = i
  656.   Next i
  657.  Close #F
  658.  
  659.  ' Сэмулировать событие нажатия, чтобы вызвать перерисовку меню
  660. mnuSelectedItem = &HFF
  661.  mnuSelectedSubItem = &HFF
  662.  Call ClickMenuItem(mnuItemStartUp)
  663.  
  664.  Exit Sub
  665. bug:
  666.  MsgBox "Ошибка при инициализации меню." & vbCrLf & Err.Description
  667. End Sub
  668.  
  669.  
  670. ' =====================================================================
  671. ' Перерисовка меню
  672. ' =====================================================================
  673.  
  674. Sub RedrawMenu()
  675.  
  676.  Dim i%, cX%: cX = mnuLeft
  677.  pctTabs.Cls
  678.  
  679.  ' Подготовка фонов
  680. StretchBlt pctTabs.hDC, 0, 0, pctTabs.Width, 76, _
  681.             pctTLay.hDC, 0, 0, 1, 76, SRCCOPY   ' Главный фон
  682. StretchBlt pctTabs.hDC, 0, 76 - 22 - mnuBottom, pctTabs.Width, 22, _
  683.             pctTLay.hDC, 1, 27, 8, 22, SRCCOPY  ' Субменю
  684. StretchBlt pctTabs.hDC, 0, 76 - 22 - mnuBottom - 2, pctTabs.Width, 2, _
  685.             pctTLay.hDC, 1, 25, 1, 2, SRCCOPY   ' Верхняя линия субменю
  686.  
  687.  ' Прорисовка субменю
  688. pctTabs.FontSize = mnuSubItemSize
  689.  mnuSubItemYend = pctTabs.Height - mnuBottom - 2 - 22 \ 2 + _
  690.                   pctTabs.TextHeight("Хуй") \ 2
  691.  mnuSubItemYstart = mnuSubItemYend - pctTabs.TextHeight("Хуй")
  692.  If UBound(mnuSubItem) > 0 Then
  693.   For i = 0 To UBound(mnuSubItem)
  694.    
  695.    ' Прорисовка активного пункта субменю
  696.   If mnuCurrentSubItem = i Then
  697.     pctTabs.Line (cX + 7 - 2, mnuSubItemYstart)-(cX + 7 + _
  698.       pctTabs.TextWidth(mnuStrings(mnuSubItem(i).strId)) + 2, _
  699.       mnuSubItemYend), mnuActColor, BF
  700.      
  701.    ' Прорисовка выделенного пункта субменю
  702.   ElseIf mnuSelectedSubItem = i Then
  703.     pctTabs.Line (cX + 7 - 2, mnuSubItemYstart)-(cX + 7 + _
  704.       pctTabs.TextWidth(mnuStrings(mnuSubItem(i).strId)) + 2, _
  705.       mnuSubItemYend), mnuSelColor, BF
  706.    
  707.    End If
  708.    cX = cX + 7 ' Применить отступ
  709.   pctTabs.CurrentY = mnuSubItemYstart
  710.    pctTabs.CurrentX = cX
  711.    pctTabs.Print mnuStrings(mnuSubItem(i).strId)
  712.    mnuSubItem(i).Xstart = cX
  713.    cX = cX + pctTabs.TextWidth(mnuStrings(mnuSubItem(i).strId)) + 7 + 2
  714.    mnuSubItem(i).Xend = cX
  715.   Next i
  716.  Else
  717.   ' Код для пустого субменю
  718. End If
  719.  
  720.  ' Прорисовка главного меню
  721. pctTabs.FontSize = mnuItemSize
  722.  mnuItemYend = 76 - 22 - mnuBottom - 1 - 26 \ 2 + pctTabs.TextHeight("Хуй") \ 2
  723.  mnuItemYstart = mnuItemYend - pctTabs.TextHeight("Хуй")
  724.  cX = mnuLeft
  725.  
  726.  For i = 0 To mnuItemCount
  727.  
  728.   ' Прорисовка активной вкладки меню
  729.  If mnuCurrentItem = i Then
  730.    DrawTransparent pctTabs.hDC, cX, 76 - mnuBottom - 22 - 27, 7, 27, _
  731.      pctTLay.hDC, 2, 0, 7, 27, vbWhite
  732.    ' Ширина угла: 7
  733.   StretchBlt pctTabs.hDC, cX + 7, 76 - mnuBottom - 22 - 27, pctTabs.TextWidth(mnuStrings(i)) + 2, 27, _
  734.      pctTLay.hDC, 9, 0, 1, 27, SRCCOPY
  735.    DrawTransparent pctTabs.hDC, cX + pctTabs.TextWidth(mnuStrings(i)) + 7 + 2, 76 - mnuBottom - 22 - 27, 7, 27, _
  736.      pctTLay.hDC, 10, 0, 7, 27, vbWhite
  737.    ' Отсуп между концом текста и завершающим углом: 2
  738.  
  739.   ' Прорисовка выделенной вкладки меню
  740.  ElseIf mnuSelectedItem = i Then
  741.    DrawTransparent pctTabs.hDC, cX, 76 - mnuBottom - 22 - 27, 7, 27, _
  742.      pctTLay.hDC, 2, 49, 7, 27, vbWhite
  743.    ' Ширина угла: 7
  744.   StretchBlt pctTabs.hDC, cX + 7, 76 - mnuBottom - 22 - 27, pctTabs.TextWidth(mnuStrings(i)) + 2, 27, _
  745.      pctTLay.hDC, 9, 49, 1, 27, SRCCOPY
  746.    DrawTransparent pctTabs.hDC, cX + pctTabs.TextWidth(mnuStrings(i)) + 7 + 2, 76 - mnuBottom - 22 - 27, 7, 27, _
  747.      pctTLay.hDC, 10, 49, 7, 27, vbWhite
  748.    ' Отсуп между концом текста и завершающим углом: 2
  749.  
  750.   End If
  751.   cX = cX + 7 ' Применить отступ
  752.  pctTabs.CurrentY = mnuItemYstart
  753.   pctTabs.CurrentX = cX
  754.   pctTabs.Print mnuStrings(i)
  755.   mnuItem(i).Xstart = cX - 7 - 2
  756.   cX = cX + pctTabs.TextWidth(mnuStrings(i)) + 7 + 2
  757.   mnuItem(i).Xend = cX
  758.  Next i
  759.  
  760.  mnuItemYstart = mnuItemYstart - 26 / 2 + pctTabs.TextHeight("Хуй") / 2
  761.  mnuItemYend = mnuItemYend + 26 / 2 - pctTabs.TextHeight("Хуй") / 2
  762.  
  763. End Sub
  764.  
  765.  
  766. ' =====================================================================
  767. ' Событие при движения мышки, выделяет неактивные вкладки
  768. ' =====================================================================
  769.  
  770. Private Sub pctTabs_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
  771.  Dim i%
  772.  
  773.  ' Область главного меню
  774. If Y >= mnuItemYstart And Y <= mnuItemYend Then
  775.   If mnuSelectedSubItem <> &HFF Then mnuSelectedSubItem = &HFF: RedrawMenu
  776.   For i = 0 To mnuItemCount
  777.    With mnuItem(i)
  778.     If x >= .Xstart And x <= .Xend Then
  779.      If mnuSelectedItem <> i Then mnuSelectedItem = i: RedrawMenu
  780.      Exit Sub
  781.     End If
  782.    End With
  783.   Next i
  784.   If mnuSelectedItem <> &HFF Then mnuSelectedItem = &HFF: RedrawMenu
  785.  
  786.  ' Область субменю
  787. ElseIf Y >= mnuSubItemYstart And Y <= mnuSubItemYend Then
  788.   If mnuSelectedItem <> &HFF Then mnuSelectedItem = &HFF: RedrawMenu
  789.   For i = 0 To UBound(mnuSubItem)
  790.    With mnuSubItem(i)
  791.     If x >= .Xstart And x <= .Xend Then
  792.      If mnuSelectedSubItem <> i Then mnuSelectedSubItem = i: RedrawMenu
  793.      Exit Sub
  794.     End If
  795.    End With
  796.   Next i
  797.   If mnuSelectedSubItem <> &HFF Then mnuSelectedSubItem = &HFF: RedrawMenu
  798.  
  799.  ' Если курсор не в области меню, сбросить все
  800. ElseIf mnuSelectedItem <> &HFF Or mnuSelectedSubItem <> &HFF Then
  801.   mnuSelectedItem = &HFF
  802.   mnuSelectedSubItem = &HFF
  803.   RedrawMenu
  804.  End If
  805. End Sub
  806.  
  807.  
  808. ' =====================================================================
  809. ' Событие при щелчке, активизирует вкладки
  810. ' =====================================================================
  811.  
  812. Private Sub pctTabs_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
  813.  Dim i%
  814.  
  815.  ' Область главного меню
  816. If Y >= mnuItemYstart And Y <= mnuItemYend Then
  817.   For i = 0 To mnuItemCount
  818.    With mnuItem(i)
  819.     If x >= .Xstart And x <= .Xend Then
  820.      If mnuCurrentItem <> i Then ClickMenuItem (i)
  821.      Exit Sub
  822.     End If
  823.    End With
  824.   Next i
  825.  
  826.  ' Область субменю
  827. ElseIf Y >= mnuSubItemYstart And Y <= mnuSubItemYend Then
  828.   For i = 0 To UBound(mnuSubItem)
  829.    With mnuSubItem(i)
  830.     If x >= .Xstart And x <= .Xend Then
  831.      If mnuCurrentSubItem <> i Then ClickMenuSubItem (i)
  832.      Exit Sub
  833.     End If
  834.    End With
  835.   Next i
  836.  
  837.  End If
  838. End Sub
  839.  
  840.  
  841. ' =====================================================================
  842. ' Активизирует выбранную вкладку меню
  843. ' =====================================================================
  844.  
  845. Sub ClickMenuItem(Index As Integer)
  846.  Dim tmpArr() As String, arrStrId() As String, arrFrmId() As String, i%
  847.  tmpArr() = Split(mnuCommand(Index), ":")
  848.  arrStrId() = Split(tmpArr(0), ",")
  849.  arrFrmId() = Split(tmpArr(1), ",")
  850.  ReDim mnuSubItem(UBound(arrStrId))
  851.  For i = 0 To UBound(arrStrId)
  852.   With mnuSubItem(i)
  853.    .frmId = CByte(arrFrmId(i)) ' Команда субменю
  854.   .strId = CByte(arrStrId(i)) ' Номер надписи субменю
  855.  End With
  856.  Next i
  857.  mnuCurrentItem = Index
  858.  Call ClickMenuSubItem(0) ' Переключиться на первую вкладку субменю
  859. End Sub
  860.  
  861.  
  862. ' =====================================================================
  863. ' Активизирует выбранную вкладку субменю
  864. ' =====================================================================
  865.  
  866. Sub ClickMenuSubItem(Index As Integer)
  867.  On Error Resume Next
  868.  Dim obj As Control
  869.  For Each obj In frm: obj.Visible = False: Next
  870.  frm(mnuSubItem(Index).frmId).Visible = True
  871.  Set obj = Nothing
  872.  mnuCurrentSubItem = Index
  873.  RedrawMenu
  874. End Sub
  875.  
  876.  
  877. ' ##################################################################### '
  878. ' #                 * РЕДАКТОР ТЕКСТА ЛЕВЕЛ СЕЛЕКТА *                 # '
  879. ' ##################################################################### '
  880.  
  881. ' =====================================================================
  882. ' Инициализация графики
  883. ' =====================================================================
  884.  
  885. Sub InitGraph()
  886.  GraphDraw
  887. End Sub
  888.  
  889.  
  890. ' =====================================================================
  891. ' Перерисовка содержимого редактора
  892. ' =====================================================================
  893.  
  894. Sub GraphDraw()
  895.  Dim i As Byte, ii As Byte
  896.  pctText.Cls
  897.  pctText.Line (ttxPointX * 16, ttxPointY * 16)-(ttxPointX * 16 + 16, ttxPointY * 16 + 16), _
  898.    RGB(255, 0, 255), BF
  899.  For i = 0 To 23
  900.   For ii = 0 To 20
  901.    If ttxData(i, ii) <> 255 Then _
  902.      DrawTransparent pctText.hDC, i * 16, ii * 16, 16, 16, _
  903.        pctTextTemp.hDC, (ttxData(i, ii) Mod 16) * 16, (ttxData(i, ii) \ 16) * 16, _
  904.        16, 16, vbBlack
  905.   Next ii
  906.  Next i
  907. End Sub
  908.  
  909.  
  910. ' =====================================================================
  911. ' Обработка нажатий клавиш в редакторе
  912. ' =====================================================================
  913.  
  914. Private Sub pctText_KeyDown(KeyCode As Integer, Shift As Integer)
  915.  Dim i As Byte
  916.  Select Case KeyCode
  917.  Case 37 ' left
  918.  If ttxPointX > 0 Then ttxPointX = ttxPointX - 1: GraphDraw
  919.  
  920.  Case 38 ' up
  921.  If ttxPointY > 0 Then
  922.    ttxPointY = ttxPointY - 1: GraphDraw
  923.   End If
  924.  
  925.  Case 39 ' right
  926.  If ttxPointX < 23 Then ttxPointX = ttxPointX + 1: GraphDraw
  927.  
  928.  Case 40 ' down
  929.  If ttxPointY < 20 Then
  930.    ttxPointY = ttxPointY + 1: GraphDraw
  931.   End If
  932.  
  933.  Case 46 ' del
  934.  For i = ttxPointX To 22
  935.    ttxData(i, ttxPointY) = ttxData(i + 1, ttxPointY)
  936.   Next i
  937.   ttxData(23, ttxPointY) = 255
  938.   GraphDraw
  939.  
  940.  Case 8 ' backspace
  941.  If ttxPointX > 0 Then
  942.    ttxPointX = ttxPointX - 1
  943.    'For i = ttxPointX To 22
  944.   ' ttxData(i, ttxPointY) = ttxData(i + 1, ttxPointY)
  945.   'Next i
  946.   'ttxData(23, ttxPointY) = 255
  947.   ttxData(ttxPointX + 1, ttxPointY) = 255
  948.   Else
  949.    ttxData(ttxPointX, ttxPointY) = 255
  950.   End If
  951.   GraphDraw
  952.  
  953.  Case 32 ' space
  954.  If ttxPointX < 23 Then
  955.    ttxPointX = ttxPointX + 1
  956.    'For i = ttxPointX To 22
  957.   ' ttxData(23 - i + ttxPointX, ttxPointY) = ttxData(22 - i + ttxPointX, ttxPointY)
  958.   'Next i
  959.   ttxData(ttxPointX - 1, ttxPointY) = 255
  960.   Else
  961.    ttxData(ttxPointX, ttxPointY) = 255
  962.   End If
  963.   GraphDraw
  964.  
  965.  End Select
  966. End Sub
  967.  
  968.  
  969. ' =====================================================================
  970. ' Ввод текста в редактор
  971. ' =====================================================================
  972.  
  973. Private Sub pctText_KeyPress(KeyAscii As Integer)
  974.  Dim OutCode%
  975.  If KeyAscii > 96 And KeyAscii < 121 Then ' a-x
  976.  OutCode = KeyAscii - 96 + 16
  977.  ElseIf KeyAscii > 64 And KeyAscii < 89 Then ' A-X
  978.  OutCode = KeyAscii - 64 + 16
  979.  ElseIf KeyAscii > 120 And KeyAscii < 123 Then ' y-z
  980.  OutCode = KeyAscii - 120 + 14
  981.  ElseIf KeyAscii > 88 And KeyAscii < 91 Then ' Y-Z
  982.  OutCode = KeyAscii - 88 + 14
  983.  ElseIf KeyAscii > 47 And KeyAscii < 58 Then ' 0-9
  984.  OutCode = KeyAscii - 48
  985.  ElseIf KeyAscii = 45 Then
  986.   OutCode = 11
  987.  Else
  988.   Exit Sub
  989.  End If
  990.  
  991.  If ttxPointX < 23 Then
  992.   Dim i As Byte
  993.   ttxPointX = ttxPointX + 1
  994.   'For i = ttxPointX To 22
  995.  ' ttxData(23 - i + ttxPointX, ttxPointY) = ttxData(22 - i + ttxPointX, ttxPointY)
  996.  'Next i
  997.  'ttxData(ttxPointX, ttxPointY) = ttxData(ttxPointX - 1, ttxPointY)
  998.  ttxData(ttxPointX - 1, ttxPointY) = OutCode
  999.   GraphDraw
  1000.  Else
  1001.   ttxData(ttxPointX, ttxPointY) = OutCode
  1002.   GraphDraw
  1003.  End If
  1004. End Sub
  1005.  
  1006.  
  1007. ' =====================================================================
  1008. ' Событие щелчка по области редактора
  1009. ' =====================================================================
  1010.  
  1011. Private Sub pctText_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
  1012.  If Button <> 1 Then Exit Sub
  1013.  ttxPointX = x \ 16
  1014.  ttxPointY = Y \ 16
  1015.  GraphDraw
  1016. End Sub
  1017.  
  1018.  
  1019.  
  1020. ' ##################################################################### '
  1021. ' #       * ПРОЧИЕ ФУНКЦИИ ДЛЯ ОСТАЛЬНЫХ ЭЛЕМЕНТОВ ПРОГРАММЫ *        # '
  1022. ' ##################################################################### '
  1023.  
  1024. ' Главные кнопки управления
  1025. Private Sub btnControls_Click(Index As Integer)
  1026.  Select Case Index
  1027.  Case 1 ' Компиляция
  1028.  ShellExecute Me.hWnd, vbNullString, _
  1029.    App.path & "\SourceCode\build.bat", vbNullString, App.path & "\SourceCode", _
  1030.    SW_SHOWNORMAL
  1031.  Case 0 ' Сохранить
  1032.  SaveData
  1033.  Case 2 ' Справка
  1034.  ShellExecute Me.hWnd, vbNullString, _
  1035.    App.path & "\Help\Index.htm", vbNullString, App.path, SW_SHOWNORMAL
  1036.  End Select
  1037. End Sub
  1038.  
  1039. ' Чекбоксы на вкладке Параметры
  1040. Private Sub chkOption_Click(Index As Integer)
  1041.  Dim i%, boolEnabled As Boolean
  1042.  boolEnabled = IIf(chkOption(Index).Value, 0, 1)
  1043.  Select Case Index
  1044.  Case 1 ' Заблокировать Твикинг
  1045.  For i = 0 To 4: chkSonic(i).Enabled = boolEnabled: Next
  1046.   For i = 0 To 5
  1047.    vsBoss(i).Enabled = boolEnabled
  1048.    txtBoss(i).Enabled = boolEnabled
  1049.   Next i
  1050.  Case 2 ' Заблокировать Тексты -> Названия зон
  1051.  For i = 0 To 8: txtZone(i).Enabled = boolEnabled: Next
  1052.   For i = 0 To 1: chkZoneAct(i).Enabled = boolEnabled: Next
  1053.  End Select
  1054. End Sub
  1055.  
  1056. ' Обновляет список порядка уровней (при загрузке и при изменении имен зон)
  1057. Sub UpdateLevelList()
  1058.  Dim ArrStr(6) As String, tmpOut$, i%, intData%
  1059.  ArrStr(0) = "GHZ": ArrStr(1) = "LZ":  ArrStr(2) = "MZ"
  1060.  ArrStr(3) = "SLZ": ArrStr(4) = "SYZ": ArrStr(5) = "SBZ"
  1061.  ArrStr(6) = "FZ"
  1062.  For i = 0 To 19
  1063.   intData = lstLvlOrder.ItemData(i)
  1064.   If intData = &H80 Then
  1065.    tmpOut = "----------------------------"
  1066.   Else
  1067.    tmpOut = "[" & ArrStr(intData \ 3)
  1068.    If intData <> 18 Then tmpOut = tmpOut & CStr(intData Mod 3 + 1)
  1069.    tmpOut = tmpOut & IIf(Len(ArrStr(intData \ 3)) = 3, "] ", "]  ")
  1070.    If intData = 18 Then tmpOut = tmpOut & " "
  1071.    tmpOut = tmpOut & txtZone(intData \ 3) & " ZONE" & _
  1072.      IIf(intData <> 18, " act " & (intData Mod 3) + 1, "")
  1073.   End If
  1074.   lstLvlOrder.List(i) = tmpOut
  1075.  Next
  1076.  lstLvlOrder.ListIndex = 0
  1077. End Sub
  1078.  
  1079. ' Кнопки Вверх/Вниз во вкладке Порядок уровней
  1080. Private Sub cmdOrder_Click(Index As Integer)
  1081.  Dim tmpStr$, intAct%
  1082.  intAct = IIf(Index = 0, -1, 1)
  1083.  With lstLvlOrder
  1084.   If intAct = -1 And .ListIndex <= 1 Then Exit Sub
  1085.   If intAct = 1 And (.ListIndex = 19 Or .ListIndex = 0) Then Exit Sub
  1086.   tmpStr = .List(lstLvlOrder.ListIndex)
  1087.   .List(.ListIndex) = .List(.ListIndex + intAct)
  1088.   .List(.ListIndex + intAct) = tmpStr
  1089.   tmpStr = .ItemData(lstLvlOrder.ListIndex)
  1090.   .ItemData(.ListIndex) = .ItemData(.ListIndex + intAct)
  1091.   .ItemData(.ListIndex + intAct) = tmpStr
  1092.   .ListIndex = .ListIndex + intAct
  1093.  End With
  1094.  UpdateOrderStatus
  1095. End Sub
  1096. Sub UpdateOrderStatus()
  1097.  Dim EnableFlag As Byte
  1098.  Select Case lstLvlOrder.ListIndex
  1099.  Case 0:    EnableFlag = 0
  1100.  Case 1:    EnableFlag = 1
  1101.  Case 19:   EnableFlag = 10
  1102.  Case Else: EnableFlag = 11
  1103.  End Select
  1104.  cmdOrder(0).Enabled = EnableFlag \ 10
  1105.  cmdOrder(1).Enabled = EnableFlag Mod 10
  1106. End Sub
  1107. Private Sub lstLvlOrder_Click()
  1108.  UpdateOrderStatus
  1109. End Sub
  1110.  
  1111. ' Открывает ссылки
  1112. Private Sub lbl_Click(Index As Integer)
  1113.  If Index = 21 Or Index = 62 Then _
  1114.  ShellExecute Me.hWnd, vbNullString, lbl(Index).Caption, _
  1115.    vbNullString, "C:\", SW_SHOWNORMAL
  1116. End Sub
  1117.  
  1118. ' Запускает одну из доступных утилит
  1119. Private Sub cmdUtil_Click(Index As Integer)
  1120. Select Case Index
  1121. Case 0 ' SonED2
  1122. ShellExecute Me.hWnd, vbNullString, App.path & "\SonED2\SonED2.exe", _
  1123.    vbNullString, App.path & "\SonED2\", SW_SHOWNORMAL
  1124. Case 1 ' SonMapEd
  1125. ShellExecute Me.hWnd, vbNullString, App.path & "\SonMapEd\SonMapEd.exe", _
  1126.    vbNullString, App.path & "\SonMapEd\", SW_SHOWNORMAL
  1127. Case 2 ' Porter
  1128. Shell App.path & "\Porter\Porter.exe", vbNormalFocus
  1129. Case 3 ' Creditor
  1130. Shell App.path & "\Creditor\Creditor.exe", vbNormalFocus
  1131. Case 4 ' Sonic1.asm
  1132. ShellExecute Me.hWnd, vbNullString, App.path & "\SourceCode\sonic1.asm", _
  1133.    vbNullString, App.path & "\SourceCode\", SW_SHOWNORMAL
  1134. End Select
  1135. End Sub
  1136.  
  1137. ' Обрабатывает вводимые символы для названий зон
  1138. Private Sub txtZone_KeyPress(Index As Integer, KeyAscii As Integer)
  1139.  KeyAscii = Asc(UCase(Chr(KeyAscii)))
  1140.  If (KeyAscii < Asc("A") Or KeyAscii > Asc("Z")) _
  1141.    And KeyAscii <> 8 And KeyAscii <> 32 Then
  1142.   KeyAscii = 0
  1143.  ElseIf Chr(KeyAscii) = "W" Or Chr(KeyAscii) = "X" Or Chr(KeyAscii) = "Q" _
  1144.   Or Chr(KeyAscii) = "J" Or Chr(KeyAscii) = "V" Then
  1145.   KeyAscii = 0
  1146.  End If
  1147. End Sub
  1148. Private Sub txtZone_LostFocus(Index As Integer)
  1149.  UpdateLevelList
  1150. End Sub
  1151.  
  1152. ' Открывает диалог для выбора локации РОМа
  1153. Private Sub btnBrowse_Click()
  1154. Dim cmdlg As New cls_dlg
  1155. With cmdlg
  1156.  .DialogTitle = "Куда сохранять будем..."
  1157.  .flags = cdlOFNExplorer
  1158.  .Filter = "РОМ Первого Соника (*.bin)|*.bin|Любой файлик|*"
  1159.  Me.Enabled = False
  1160.  .ShowSave
  1161.  Me.Enabled = True
  1162.  If .FileName = "" Then Exit Sub
  1163.  txtCompPath = .FileName
  1164.  .FileName = "": .Filter = "": .flags = 0: .DialogTitle = ""
  1165. End With
  1166. Set cmdlg = Nothing
  1167. End Sub
  1168.  
  1169. ' Изменение списка песен в зависимости от выбранной группы
  1170. Private Sub cmbMusGroup_Click(Index As Integer)
  1171.  cmbMusGroup_Change Index
  1172. End Sub
  1173. Private Sub cmbMusGroup_Change(Index As Integer)
  1174.  On Error Resume Next
  1175.  Dim FileName As String, arr() As String
  1176.  cmbMusList(Index).Clear ' Очищаем список текущих песен
  1177. FileName = Dir(App.path & "\Music\", vbNormal)
  1178.  Do While FileName <> ""
  1179.   arr() = Split(Replace(FileName, "_", " ", , 1), " ")
  1180.   If arr(0) = cmbMusGroup(Index) Then _
  1181.     cmbMusList(Index).AddItem Replace(arr(1), "_", " ")
  1182.   FileName = Dir()
  1183.  Loop
  1184.  If cmbMusList(Index).ListCount > 0 Then cmbMusList(Index).ListIndex = 0
  1185. End Sub
  1186.  
  1187. ' Контролы менеджера песенок
  1188. Private Sub lstManagerGroup_Click()
  1189.  On Error Resume Next
  1190.  Dim FileName As String, arr() As String
  1191.  lstManagerSong.Clear ' Очищаем список текущих песен
  1192. FileName = Dir(App.path & "\Music\", vbNormal)
  1193.  Do While FileName <> ""
  1194.   arr() = Split(Replace(FileName, "_", " ", , 1), " ")
  1195.   If UCase(arr(0)) = UCase(lstManagerGroup) Then _
  1196.     lstManagerSong.AddItem Replace(arr(1), "_", " ")
  1197.   FileName = Dir()
  1198.  Loop
  1199.  If lstManagerSong.ListCount > 0 Then lstManagerSong.ListIndex = 0
  1200. End Sub
  1201.  
  1202. ' Команды для менеджера
  1203. Private Sub cmdManager_Click(Index As Integer)
  1204.  Dim strIn$, i%, intRem%
  1205.  Select Case Index
  1206.  Case 0 ' Добавить группу
  1207.  strIn = InputBox("Введите имя группы: ")
  1208.   If strIn = "" Then Exit Sub
  1209.   For i = 0 To lstManagerGroup.ListCount - 1
  1210.    If lstManagerGroup.List(i) = strIn Then ' Нет ли уже такой группы?
  1211.    MsgBox "Такая группа уже есть.", vbExclamation
  1212.     Exit Sub
  1213.    End If
  1214.   Next i
  1215.   lstManagerGroup.AddItem strIn
  1216.   lstManagerGroup.ListIndex = lstManagerGroup.ListCount - 1
  1217.   For i = 0 To cmbMusGroup.UBound: cmbMusGroup(i).AddItem strIn: Next
  1218.  
  1219.  Case 1 ' Удалить группу
  1220.  intRem = lstManagerGroup.ListIndex
  1221.   If intRem < 3 Then
  1222.    MsgBox "Нельзя удалить священную группу!", vbCritical
  1223.    Exit Sub
  1224.   End If
  1225.   lstManagerGroup.RemoveItem intRem
  1226.   For i = 0 To cmbMusGroup.UBound
  1227.    If cmbMusGroup(i).ListIndex = intRem Then cmbMusGroup(i).ListIndex = intRem - 1
  1228.    cmbMusGroup(i).RemoveItem intRem
  1229.   Next
  1230.   lstManagerGroup.ListIndex = intRem - 1
  1231.   GoTo UpdateListFile
  1232.  
  1233.  Case 2 ' Добавить песню
  1234.  Dim cmdlg As New cls_dlg
  1235.   With cmdlg
  1236.    .DialogTitle = "Куда сохранять будем..."
  1237.    .flags = cdlOFNExplorer Or cdlOFNHideReadOnly
  1238.    .Filter = "SMPS-музыка (*.bin)|*.bin|Любой файлик|*"
  1239.    Me.Enabled = False
  1240.    .ShowOpen
  1241.    Me.Enabled = True
  1242.    If .FileName = "" Or Dir(.FileName) = "" Then Exit Sub
  1243.    strIn = .FileName
  1244.    .FileName = "": .Filter = "": .flags = 0: .DialogTitle = ""
  1245.   End With
  1246.   Set cmdlg = Nothing
  1247.   Dim strOut$: strOut = Replace(strIn, ".bin", "")
  1248.   For i = 0 To Len(strOut) - 1
  1249.    If Mid(strOut, Len(strOut) - i, 1) = "\" Then
  1250.     strOut = Mid(strOut, Len(strOut) - i + 1, Len(strOut))
  1251.     Exit For
  1252.    End If
  1253.   Next i
  1254.   strOut = InputBox("Введите имя песни: ", , strOut)
  1255.   If strOut = "" Then Exit Sub
  1256.   FileCopy strIn, App.path & "\Music\" & lstManagerGroup & _
  1257.     "_" & Replace(strOut, " ", "_")
  1258.   lstManagerGroup_Click ' Обновить список песен
  1259.  GoTo UpdateListFile
  1260.  
  1261.  Case 3 ' Удалить песню
  1262.  If lstManagerSong.ListIndex < 0 Then Exit Sub
  1263.   If MsgBox("Удалить " & lstManagerSong & "?", vbQuestion Or vbYesNo) = vbNo Then: _
  1264.     Exit Sub
  1265.   Kill App.path & "\Music\" & lstManagerGroup & _
  1266.     "_" & Replace(lstManagerSong, " ", "_")
  1267.   lstManagerGroup_Click ' Обновить список песен
  1268.  
  1269.  End Select
  1270.  
  1271. UpdateListFile:
  1272.  Dim F%: F = FreeFile
  1273.  Open App.path & "\Data\musiclist.dat" For Output As #F
  1274.   For i = 0 To lstManagerGroup.ListCount - 1
  1275.    Print #F, lstManagerGroup.List(i) & _
  1276.      IIf(i = lstManagerGroup.ListCount - 1, "", vbCrLf);
  1277.   Next i
  1278.  Close #F
  1279.  
  1280. End Sub
  1281.  
  1282. ' Количество ударов у босса
  1283. Private Sub vsBoss_Change(Index As Integer)
  1284.  txtBoss(Index) = Abs(vsBoss(Index).Value)
  1285. End Sub
  1286.  
  1287. ' Флажок для включения замены арта
  1288. Private Sub chkArt_Click(Index As Integer)
  1289.  Dim boolEnabled As Boolean, i%
  1290.  boolEnabled = IIf(chkArt(Index).Value, 1, 0)
  1291.  Select Case Index
  1292.  Case 0 ' Monitors
  1293.  For i = 0 To optArtMon.UBound: optArtMon(i).Enabled = boolEnabled: Next i
  1294.  Case 1 ' HUD
  1295.  For i = 0 To optArtHUD.UBound: optArtHUD(i).Enabled = boolEnabled: Next i
  1296.  End Select
  1297. End Sub
  1298.  
  1299. ' Нажатие на лого (пасхалочка ^_^)
  1300. Private Sub imgLogo_Click(Index As Integer)
  1301.  imgLogo(1).Visible = Not imgLogo(1).Visible
  1302. End Sub
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!