1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
| '
' Базовый код создан через: Hex2Abs - v 0.1.2
' >Quiet Snow< 2011-2025г.
'
'
' При запуске через QuickBasic запускать QB.EXE с ключом /L
'
'
' Структура DTA для работы с диском
TYPE DataTransferArea
DtaNoUse AS STRING * 21
DtaAtrib AS STRING * 1
DtaTime AS INTEGER
DtaData AS INTEGER
DtaFileSize AS LONG
DtaFileName AS STRING * 13
END TYPE
CONST CTMDbg = 0 ' Узнать кол-во данных для ABSOLUTE в CodeToMem
' Загрузка кода
DECLARE SUB CodeToMem (CodSeg AS LONG, CodPtr AS LONG, NumLines AS INTEGER)
' Инициализация кода
DECLARE SUB InitRoutines ()
' Работа с векторами
DECLARE SUB SetIntVec (IntNum AS INTEGER, CSegm&, COffs&)
DECLARE SUB RestoreVec (IntNum AS INTEGER)
' Работа с клавиатурой
DECLARE SUB KeybActivate ()
DECLARE SUB KeybClose ()
DECLARE FUNCTION KeyPress% (KNum%)
' Работа с мышью
DECLARE SUB MouUpdate ()
DECLARE SUB MouBtCalc ()
' Работа с джойстиком
DECLARE SUB GetJoy ()
' Работа с таймером
DECLARE SUB TimerActivate (Hertz AS LONG)
DECLARE SUB TimerClose ()
DECLARE SUB Delay (Ms AS LONG)
' Сканирование текущей директории (DTA)
DECLARE SUB SetMask (Mask AS STRING)
DECLARE SUB ScanDir ()
DECLARE FUNCTION GetMinNames ()
DECLARE FUNCTION GetMaxNames ()
DECLARE SUB GetCurDir ()
DECLARE SUB GetCurDisk ()
DECLARE FUNCTION GetNameByNum$ (Num AS INTEGER)
DECLARE SUB PrintDirFixed (Num1 AS INTEGER, Num2 AS INTEGER, Sel AS INTEGER)
' Кастомный вывод символа
DECLARE SUB Symb (x AS LONG, y AS LONG, s AS LONG, cv1 AS LONG, cv2 AS LONG)
DECLARE SUB TWnd (x AS LONG, y AS LONG, x2 AS LONG, y2 AS LONG, Cv AS LONG)
REM $DYNAMIC
DIM SHARED Code1(472) AS INTEGER ' Код и данные подпрограмм прерываний
DIM SHARED Code2(18) AS INTEGER ' Код подпрограммы клавиатуры
DIM SHARED Code3(23) AS INTEGER ' Код подпрограммы мыши
DIM SHARED Code4(17) AS LONG ' Код подпрограммы таймера
DIM SHARED Code5(13) AS INTEGER ' Получение адреса DTA
DIM SHARED Code6(14) AS INTEGER ' Установка адреса DTA
DIM SHARED Code7(25) AS INTEGER ' Нахождение первого вхождения
DIM SHARED Code8(24) AS INTEGER ' Нахождение следующего файла
DIM SHARED Code9(10) AS INTEGER ' Получить текущ. директорию
DIM SHARED Code10(8) AS INTEGER ' Получить текущ. диск
' Для работы пп векторов, мыши, клавиатуры и таймера
DIM SHARED Kolic AS LONG ' Кол-во байт в подпрограмме
DIM SHARED MultiKey(127) AS INTEGER ' Массив клавиш клавиатуры
DIM SHARED OldK(127) AS INTEGER ' Старые нажатия (форм сами)
DIM SHARED CuMx AS LONG ' Кастомные координаты курсора
DIM SHARED CuMy AS LONG
DIM SHARED MbO AS INTEGER ' Старое значение кнопок мыши
DIM SHARED Hz AS LONG ' Герц
' Статус клика кн. мыши при отпускании
DIM SHARED LClick AS INTEGER
DIM SHARED CClick AS INTEGER
DIM SHARED RClick AS INTEGER
' Статус клика кн. мыши при нажатии
DIM SHARED LClickPr AS INTEGER
DIM SHARED CClickPr AS INTEGER
DIM SHARED RClickPr AS INTEGER
DIM SHARED DTA AS DataTransferArea
DIM SHARED MaskPath AS STRING * 64
DIM SHARED InDirNames(30) AS STRING * 13
DIM SHARED CurrDir AS STRING * 256
DIM SHARED CurDir AS STRING ' Текущая директория
DIM SHARED OldDir AS STRING ' Сохранить первоначальную папку
DIM SHARED DirFNames AS STRING
DIM SHARED QuaNames AS INTEGER
' Для джойстика
DIM SHARED JUp AS INTEGER, JDn AS INTEGER
DIM SHARED JLf AS INTEGER, JRg AS INTEGER
DIM SHARED JTrian AS INTEGER, JSquar AS INTEGER
DIM SHARED JRound AS INTEGER, JCross AS INTEGER
DIM SHARED JL1 AS INTEGER, JL2 AS INTEGER
DIM SHARED JR1 AS INTEGER, JR2 AS INTEGER
' Пользовательские массивы и переменные
DIM FVib AS INTEGER, MinV AS INTEGER, MaxV AS INTEGER
DIM Rdr AS INTEGER, Ferr AS INTEGER
DIM i AS INTEGER
DIM LClks AS INTEGER, CClks AS INTEGER, RClks AS INTEGER
' Инициализация
InitRoutines
' Пользовательская программа
CLS
ScanDir ' Скан директории [ INT 21h ]
OldDir = CHR$(Code10(0)) + ":\" + CurDir
MinV = GetMinNames
MaxV = GetMaxNames
FVib = MinV: Rdr = -1
TWnd 0, 0, 79, 24, 1
KeybActivate ' Включаем обработчик [ INT 9 ]
TimerActivate (1000) ' 1000 прерываний в секунду [ INT 8 ]
' Тестовые задержки
LOCATE 1
FOR i = 112 TO 44 STEP -3
Delay CLNG(i)
LOCATE CSRLIN + 1, 2
PRINT " Delay"; i; "ms";
NEXT: LOCATE 1
FOR i = 46 TO 2 STEP -2
Delay CLNG(i): LOCATE CSRLIN + 1, 40
PRINT " Delay"; i; "ms";
NEXT
Delay 800
CLS
LOCATE 16, 33
TWnd 31, 14, 45, 22, 7
PrintDirFixed 1, 7, FVib
DO
MouUpdate ' Берём параметры мыши [ INT 51 ]
MouBtCalc ' Калькуляция кликов
GetJoy ' Опрашиваем джойстик
' Мышь
LClks = LClks - LClickPr
CClks = CClks - CClickPr
RClks = RClks - RClickPr
LOCATE 2, 1
COLOR 15: PRINT " Mouse": COLOR 7
PRINT " Mx:"; Code3(3), "My:"; Code3(4), " Delta", "dMx:"; Code3(0), "dMy:"; Code3(1)
PRINT " Buttons:"; Code3(2); " LClicks: "; LClks; " CClicks: "; CClks; " RClicks: "; RClks
CuMx = CuMx + CLNG(Code3(0))
CuMy = CuMy + CLNG(Code3(1))
PRINT " Custom mouse position Mx:"; CuMx, "My:"; CuMy
' Клавиатура
LOCATE 7, 1
COLOR 15: PRINT " KeyBoard": COLOR 7
FOR i = 0 TO 127
PRINT MultiKey(i);
NEXT
' Таймер
LOCATE 14, 1
COLOR 15: PRINT " Timer": COLOR 7
PRINT " Hertz:"; Hz;
LOCATE , 17: PRINT "Time: "; TIME$
PRINT " Incremental (Int 8):"; Code4(0)
PRINT " QBasic Timer:"; TIMER
PRINT
' Директории
LOCATE 14, 30
COLOR 15: PRINT " Directories": COLOR 7
IF Rdr AND -GetMinNames THEN
LOCATE 16, 33
PrintDirFixed FVib - 3, FVib + 3, FVib
LOCATE 1, 1
PRINT SPACE$(80);
LOCATE 1, 1
COLOR 8
PRINT "DIR: "; CHR$(Code10(0)) + ":\" + CurDir
COLOR 7
Rdr = 0
END IF
' Кнопки: Вверх \ Вниз
IF KeyPress(72) AND FVib > MinV THEN
FVib = FVib - 1: Rdr = -1
END IF
IF KeyPress(80) AND FVib < MaxV THEN
FVib = FVib + 1: Rdr = -1
END IF
' Кнопка ENTER
IF KeyPress(28) THEN
' Выбор текущей директории встроенной функцией
ON ERROR GOTO DirErr: Ferr = 0
CHDIR GetNameByNum$(FVib)
ON ERROR GOTO 0
' Если нет ошибок(выбор произошёл)
IF NOT Ferr THEN
' Сканируем заново
ScanDir ' Скан директории [ INT 21h ]
' Границы записей
MinV = GetMinNames
MaxV = GetMaxNames
FVib = MinV
' Перерисовка
LOCATE 16, 33
PrintDirFixed 1, 7, FVib
Rdr = -1
END IF
END IF
' Джойстик
LOCATE 19, 1
COLOR 15: PRINT " Joystick": COLOR 7
LOCATE 20, 2: IF JL1 THEN COLOR 10 ELSE COLOR 8
PRINT "L1"
LOCATE 20, 5: IF JL2 THEN COLOR 10 ELSE COLOR 8
PRINT "L2"
LOCATE 20, 11: IF JR1 THEN COLOR 10 ELSE COLOR 8
PRINT "R1"
LOCATE 20, 14: IF JR2 THEN COLOR 10 ELSE COLOR 8
PRINT "R2"
IF JLf THEN Symb 1, 21, 17, 10, 0 ELSE Symb 1, 21, 17, 8, 0
IF JRg THEN Symb 5, 21, 16, 10, 0 ELSE Symb 5, 21, 16, 8, 0
IF JUp THEN Symb 3, 20, 30, 10, 0 ELSE Symb 3, 20, 30, 8, 0
IF JDn THEN Symb 3, 22, 31, 10, 0 ELSE Symb 3, 22, 31, 8, 0
IF JSquar THEN Symb 10, 21, 254, 10, 0 ELSE Symb 10, 21, 254, 8, 0
IF JRound THEN Symb 14, 21, 111, 10, 0 ELSE Symb 14, 21, 111, 8, 0
IF JTrian THEN Symb 12, 20, 30, 10, 0 ELSE Symb 12, 20, 30, 8, 0
IF JCross THEN Symb 12, 22, 120, 10, 0 ELSE Symb 12, 22, 120, 8, 0
LOOP UNTIL MultiKey(1)
TimerClose
KeybClose
CHDIR OldDir
END
DirErr: Ferr = -1
RESUME NEXT
' INLINE КОДЫ
' код работы с векторами
Asm1:
DATA 11112222333306505352572E8B3E20032E
DATA 8B1E22032E8B0E240333C02E8A8580020A
DATA C00F857003B801002E88858002FA33C08E
DATA C0C1E702268B152E89950000268B55022E
DATA 8995020026890D26895D02FB5F5A5B5807
DATA CB065053572E8B3E200333C02E8A858002
DATA 0AC00F84AD0333C02E88858002FA33C08E
DATA C0C1E7022E8B9D000026891D2E8B9D0200
DATA 26895D02FB5F5B5807CB
' код клавиатуры
Asm2: DATA 505306B811118EC033DBE460A880
DATA 7803BBFFFF257F0093D1E3268987222207
DATA 5BB020E62058CF
' код мыши
Asm3: DATA 0000000000000000000060B80B00
DATA CD332E890E00002E89160200B80300CD33
DATA 2E891E04002E890E06002E8916080061CB
' код таймера
Asm4: DATA 0000000011111111222222226650
DATA 1E0E1F2E66FF0600002E66A108002E6601
DATA 0604002E66813E0400FFFF000077081FB0
DATA 20E6206658CF2E66812E0400FFFF00001F
DATA 6658EA33333333
' Получение адреса DTA
Asm5: DATA 221144339C5053B8002FCD218CC0
DATA 2EA300002E891E02005B589DCB
' Установка адреса DTA
Asm6: DATA 221144339C50521E2EA100008ED8
DATA B8001A2E8B160200CD211F5A589DCB
' Нахождение первого вхождения
Asm7: DATA 2211443366559C5051521E33C02E
DATA A300002EA102008ED82E8B160400B8004E
DATA B93500F8CD2172072EC706000001001F5A
DATA 59589DCB
' Нахождение следующего файла
Asm8: DATA 2211443366559C50521E33C02EA3
DATA 00002EA102008ED82E8B160400B8004FB9
DATA 3500F8CD2172072EC706000001001F5A58
DATA 9DCB
' Получение текущей директории
Asm9: DATA 11112222601E0E1FC536999933D2
DATA B447CD211F61CB
' Получение текущего диска
Asm10: DATA 000050B80019CD210441982EA300
DATA 0058CB
SUB CodeToMem (CodSeg AS LONG, CodPtr AS LONG, NumLines AS INTEGER)
DIM Lst AS INTEGER, Lba AS INTEGER
DIM Sc AS STRING, Pr AS INTEGER
DIM IntInMas AS LONG, LngInMas AS LONG
Kolic = 0
DEF SEG = CodSeg
FOR Lst = 1 TO NumLines 'Грузим строки кода
READ Sc
FOR Lba = 1 TO LEN(Sc) STEP 2 'Преобразовываем в байты
Pr = VAL("&H" + MID$(Sc, Lba, 2))
POKE CodPtr + Kolic, Pr
Kolic = Kolic + 1
NEXT
NEXT
' Рассчитать кол-во байт в массиве
IntInMas = ((Kolic + (Kolic AND 1)) \ 2) - 1
LngInMas = ((Kolic + (Kolic AND 3)) \ 4) - 1
IF CTMDbg THEN
PRINT "Integers upper bound in DIM:"; IntInMas; STRING$(9, 196),
PRINT " Longs UB in DIM:"; LngInMas;
END IF
DEF SEG
END SUB
REM $STATIC
SUB Delay (Ms AS LONG)
DIM TmStop AS LONG
TmStop = Code4(0) + Ms
WHILE Code4(0) < TmStop
WEND
END SUB
SUB GetCurDir
CurrDir = SPACE$(255)
DEF SEG = VARSEG(Code9(0))
CALL ABSOLUTE(VARPTR(Code9(0)) + 4)
DEF SEG
CurDir = LEFT$(CurrDir, INSTR(CurrDir, CHR$(0)) - 1)
END SUB
SUB GetCurDisk
'Code10(0) = 0
DEF SEG = VARSEG(Code10(0))
CALL ABSOLUTE(VARPTR(Code10(0)) + 2)
DEF SEG
END SUB
SUB GetJoy
JL1 = STRIG(1)
JL2 = STRIG(5)
JR1 = STRIG(3)
JR2 = STRIG(7)
IF STICK(0) > 192 THEN
JRg = -1
JLf = 0
ELSE
JRg = 0
IF STICK(0) < 64 THEN JLf = -1 ELSE JLf = 0
END IF
IF STICK(1) > 192 THEN
JDn = -1
JUp = 0
ELSE
JDn = 0
IF STICK(1) < 64 THEN JUp = -1 ELSE JUp = 0
END IF
IF STICK(2) > 192 THEN
JRound = -1
JSquar = 0
ELSE
JRound = 0
IF STICK(2) < 64 THEN JSquar = -1 ELSE JSquar = 0
END IF
IF STICK(3) > 192 THEN
JCross = -1
JTrian = 0
ELSE
JCross = 0
IF STICK(3) < 64 THEN JTrian = -1 ELSE JTrian = 0
END IF
END SUB
FUNCTION GetMaxNames
GetMaxNames = QuaNames
END FUNCTION
FUNCTION GetMinNames
IF QuaNames > 0 THEN
GetMinNames = 1
ELSE : GetMinNames = 0
END IF
END FUNCTION
FUNCTION GetNameByNum$ (Num AS INTEGER)
DIM TName AS STRING
DIM OldFi AS INTEGER, Fi AS INTEGER, NumName AS INTEGER
OldFi = 1: NumName = 1
DO
Fi = INSTR(OldFi, DirFNames, CHR$(0))
IF Num = NumName THEN
TName = MID$(DirFNames, OldFi, Fi - OldFi)
GetNameByNum$ = TName
EXIT FUNCTION
END IF
OldFi = Fi + 1
NumName = NumName + 1
LOOP UNTIL Fi = 0
END FUNCTION
REM $DYNAMIC
SUB InitRoutines
DIM p AS INTEGER
CLS
' Код работы с векторами прерываний
RESTORE Asm1
CodeToMem VARSEG(Code1(400)), VARPTR(Code1(400)), 9
' Код работы с клавиатурой
RESTORE Asm2
CodeToMem VARSEG(Code2(0)), VARPTR(Code2(0)), 3
' Вставим в код динамичски меняющиеся сегмент и смещение
DEF SEG = VARSEG(Code2(0))
POKE VARPTR(Code2(0)) + 4, ASC(MKL$(VARSEG(MultiKey(0))))
POKE VARPTR(Code2(0)) + 5, ASC(MID$(MKL$(VARSEG(MultiKey(0))), 2, 1))
POKE VARPTR(Code2(0)) + 28, ASC(MKL$(VARPTR(MultiKey(0))))
POKE VARPTR(Code2(0)) + 29, ASC(MID$(MKL$(VARPTR(MultiKey(0))), 2, 1))
DEF SEG
' Код работы с мышью
RESTORE Asm3
CodeToMem VARSEG(Code3(0)), VARPTR(Code3(0)), 3
' Код работы с таймером (перехват с компенсацией)
RESTORE Asm4
CodeToMem VARSEG(Code4(0)), VARPTR(Code4(0)), 5
DIM b1 AS INTEGER, b2 AS INTEGER, b3 AS INTEGER, b4 AS INTEGER
DEF SEG = 0
b1 = PEEK(4 * 8) ' Смещение
b2 = PEEK(4 * 8 + 1) ' Смещение
b3 = PEEK(4 * 8 + 2) ' Сегмент
b4 = PEEK(4 * 8 + 3) ' Сегмент
DEF SEG = VARSEG(Code4(0))
' Вставляем адрес старого вектора для JMP
POKE VARPTR(Code4(0)) + Kolic - 4, b1
POKE VARPTR(Code4(0)) + Kolic - 3, b2
POKE VARPTR(Code4(0)) + Kolic - 2, b3
POKE VARPTR(Code4(0)) + Kolic - 1, b4
DEF SEG
' Коды работы с DTA (поиск файлов в папке)
RESTORE Asm5
CodeToMem VARSEG(Code5(0)), VARPTR(Code5(0)), 2
RESTORE Asm6
CodeToMem VARSEG(Code6(0)), VARPTR(Code6(0)), 2
RESTORE Asm7
CodeToMem VARSEG(Code7(0)), VARPTR(Code7(0)), 4
RESTORE Asm8
CodeToMem VARSEG(Code8(0)), VARPTR(Code8(0)), 4
' Получение текущей директории
RESTORE Asm9
CodeToMem VARSEG(Code9(0)), VARPTR(Code9(0)), 2
DIM SegStAsm AS LONG, PtrStAsm AS LONG
' Получим см и сег строки на 64 символа
SegStAsm = VARSEG(CurrDir)
PtrStAsm = VARPTR(CurrDir)
' Скопируем память переменных в маш код
DEF SEG = VARSEG(SegStAsm)
b1 = PEEK(VARPTR(SegStAsm)) ' Сегмент LB
b2 = PEEK(VARPTR(SegStAsm) + 1) ' Сегмент HB
DEF SEG = VARSEG(PtrStAsm)
b3 = PEEK(VARPTR(PtrStAsm)) ' Смещение LB
b4 = PEEK(VARPTR(PtrStAsm) + 1) ' Смещение HB
DEF SEG = VARSEG(Code9(0))
POKE VARPTR(Code9(0)), b3
POKE VARPTR(Code9(0)) + 1, b4
POKE VARPTR(Code9(0)) + 2, b1
POKE VARPTR(Code9(0)) + 3, b2
DEF SEG
' Получим смещение на начало кода
PtrStAsm = VARPTR(Code9(0))
' Получим байты этого смещения
DEF SEG = VARSEG(PtrStAsm)
b1 = PEEK(VARPTR(PtrStAsm)) ' Смещение LB
b2 = PEEK(VARPTR(PtrStAsm) + 1) ' Смещение HB
' Забьём байты в память (в непоср смещение инструкции LDS)
DEF SEG = VARSEG(Code9(0))
POKE VARPTR(Code9(0)) + 10, b1 ' Смещение LB
POKE VARPTR(Code9(0)) + 11, b2 ' Смещение HB
DEF SEG
' Получение текущего диска
RESTORE Asm10
CodeToMem VARSEG(Code10(0)), VARPTR(Code10(0)), 2
SetMask "*.*"
IF CTMDbg THEN SLEEP: END
END SUB
SUB KeybActivate
SetIntVec 9, VARSEG(Code2(0)), VARPTR(Code2(0))
END SUB
SUB KeybClose
RestoreVec 9
END SUB
REM $STATIC
FUNCTION KeyPress% (KNum%)
IF MultiKey(KNum%) <> OldK(KNum%) THEN
IF MultiKey(KNum%) THEN
KeyPress% = -1
ELSE
KeyPress% = 0
END IF
END IF
OldK(KNum%) = MultiKey(KNum%)
END FUNCTION
SUB MouBtCalc
' Клик отпускания
IF ((MbO AND 1) IMP (Code3(2) AND 1)) = -2 THEN LClick = -1 ELSE LClick = 0
IF ((MbO AND 2) IMP (Code3(2) AND 2)) = -3 THEN RClick = -1 ELSE RClick = 0
IF ((MbO AND 4) IMP (Code3(2) AND 4)) = -5 THEN CClick = -1 ELSE CClick = 0
' Клик нажатия
IF ((Code3(2) AND 1) IMP (MbO AND 1)) = -2 THEN LClickPr = -1 ELSE LClickPr = 0
IF ((Code3(2) AND 2) IMP (MbO AND 2)) = -3 THEN RClickPr = -1 ELSE RClickPr = 0
IF ((Code3(2) AND 4) IMP (MbO AND 4)) = -5 THEN CClickPr = -1 ELSE CClickPr = 0
END SUB
REM $DYNAMIC
SUB MouUpdate
MbO = Code3(2)
DEF SEG = VARSEG(Code3(0))
CALL ABSOLUTE(VARPTR(Code3(0)) + 10)
DEF SEG
END SUB
REM $STATIC
SUB PrintDirFixed (Num1 AS INTEGER, Num2 AS INTEGER, Sel AS INTEGER)
DIM TName AS STRING
DIM OldFi AS INTEGER, Fi AS INTEGER, NumName AS INTEGER
DIM N1 AS INTEGER, N2 AS INTEGER
DIM CrPosX AS INTEGER, CrLinY AS INTEGER
N1 = Num1: N2 = Num2
IF N1 < GetMinNames THEN N1 = GetMinNames
IF N2 > GetMaxNames THEN N2 = GetMaxNames
OldFi = 1: NumName = 1
CrPosX = POS(0): CrLinY = CSRLIN
DO
Fi = INSTR(OldFi, DirFNames, CHR$(0))
IF NumName >= N1 THEN
IF Sel = NumName THEN COLOR 15, 1 ELSE COLOR 7, 0
IF NumName > N2 THEN EXIT DO
TName = MID$(DirFNames, OldFi, Fi - OldFi)
CrLinY = CSRLIN
LOCATE , CrPosX
PRINT SPACE$(13)
LOCATE CrLinY, CrPosX
PRINT TName
END IF
OldFi = Fi + 1
NumName = NumName + 1
LOOP UNTIL Fi = 0
WHILE N2 < Num2
LOCATE , CrPosX
PRINT SPACE$(13)
N2 = N2 + 1
WEND
END SUB
REM $DYNAMIC
SUB RestoreVec (IntNum AS INTEGER)
IF IntNum > 159 OR IntNum < 0 THEN EXIT SUB
Code1(400) = IntNum
DEF SEG = VARSEG(Code1(0))
CALL ABSOLUTE(VARPTR(Code1(0)) + 886)
DEF SEG
END SUB
REM $STATIC
SUB ScanDir
DIM DTAOLDSeg%, DTAOLDPtr%
DIM AddName AS STRING
' Узнаем текущий диск
GetCurDisk
' Узнаем текущую директорию
GetCurDir
' Вызываем функцию получения адреса DTA
DEF SEG = VARSEG(Code5(0))
CALL ABSOLUTE(VARPTR(Code5(2)))
DTAOLDSeg% = Code5(0) ' Сохраним указатель на DTA
DTAOLDPtr% = Code5(1)
' Вызываем функцию установки адреса DTA
Code6(0) = VARSEG(DTA) ' Новый адрес
Code6(1) = VARPTR(DTA)
DEF SEG = VARSEG(Code6(0))
CALL ABSOLUTE(VARPTR(Code6(2)))
' Поиск 1-го вхождения
Code7(1) = VARSEG(MaskPath) ' Адрес шаблона
Code7(2) = VARPTR(MaskPath)
QuaNames = 0
DirFNames = ""
DEF SEG = VARSEG(Code7(0))
CALL ABSOLUTE(VARPTR(Code7(3)))
' Если вхождение найдено
IF Code7(0) THEN
AddName = LEFT$(DTA.DtaFileName, INSTR(DTA.DtaFileName, CHR$(0)))
' Если не 1 точка, тогда добавляем
IF AddName <> ("." + CHR$(0)) THEN
IF AddName = (".." + CHR$(0)) THEN
IF CurDir <> "" THEN
DirFNames = DirFNames + AddName
QuaNames = QuaNames + 1
END IF
ELSE
DirFNames = DirFNames + AddName
QuaNames = QuaNames + 1
END IF
END IF
DEF SEG = VARSEG(Code8(0))
CALL ABSOLUTE(VARPTR(Code8(3)))
IF Code8(0) THEN
AddName = LEFT$(DTA.DtaFileName, INSTR(DTA.DtaFileName, CHR$(0)))
IF AddName = (".." + CHR$(0)) THEN
IF CurDir <> "" THEN
DirFNames = DirFNames + AddName
QuaNames = QuaNames + 1
END IF
ELSE
DirFNames = DirFNames + AddName
QuaNames = QuaNames + 1
END IF
DO ' Ищем всё последующие вхождения
CALL ABSOLUTE(VARPTR(Code8(3)))
IF Code8(0) THEN
QuaNames = QuaNames + 1
'PRINT LEFT$(DTA.DtaFileName, INSTR(DTA.DtaFileName, CHR$(0)) - 1)
DirFNames = DirFNames + LEFT$(DTA.DtaFileName, INSTR(DTA.DtaFileName, CHR$(0)))
END IF
LOOP UNTIL Code8(0) = 0
END IF
END IF
' Восстанавливаем адрес DTA
Code6(0) = DTAOLDSeg%
Code6(1) = DTAOLDPtr%
DEF SEG = VARSEG(Code6(0))
CALL ABSOLUTE(VARPTR(Code6(2)))
DEF SEG
END SUB
REM $DYNAMIC
SUB SetIntVec (IntNum AS INTEGER, CSegm&, COffs&)
IF IntNum > 159 OR IntNum < 0 THEN EXIT SUB
Code1(400) = IntNum
DEF SEG = VARSEG(Code1(0))
POKE 802, ASC(MKL$(CSegm&))
POKE 803, ASC(MID$(MKL$(CSegm&), 2, 1))
POKE 804, ASC(MKL$(COffs&))
POKE 805, ASC(MID$(MKL$(COffs&), 2, 1))
CALL ABSOLUTE(VARPTR(Code1(0)) + 806)
DEF SEG
END SUB
REM $STATIC
SUB SetMask (Mask AS STRING)
MaskPath = Mask + CHR$(0)
END SUB
SUB Symb (x AS LONG, y AS LONG, s AS LONG, cv1 AS LONG, cv2 AS LONG)
DIM Adr AS LONG
Adr = 160 * y + x + x
DEF SEG = &HB800
POKE Adr, s
POKE Adr + 1, cv1 + cv2 * 16
DEF SEG
END SUB
REM $DYNAMIC
SUB TimerActivate (Hertz AS LONG)
DIM Divisor AS LONG
Divisor = 1193182 / Hertz ' Частота такт генератора дел на циклы
IF Divisor < 2 THEN Divisor = 2 ' Ограничители делителя
IF Divisor > 65535 THEN Divisor = 65535
Hz = 1193182 / Divisor ' Реальная частота
Code4(0) = 0: Code4(1) = 0 ' Обнулить счётчики
DEF SEG = VARSEG(Code4(0)) ' Делитель в подпрограмму побайтово
POKE VARPTR(Code4(0)) + 8, Divisor AND 255
POKE VARPTR(Code4(0)) + 9, Divisor \ 256
POKE VARPTR(Code4(0)) + 10, 0
POKE VARPTR(Code4(0)) + 11, 0
DEF SEG
' Установка прерывания на таймер
SetIntVec 8, VARSEG(Code4(0)), VARPTR(Code4(0)) + 12
' Меняем скорость таймера(0 канал) согласно делителю
OUT &H43, &H36 ' Управляющий регистр
OUT &H40, ASC(MKL$(Divisor)) ' Младший байт
OUT &H40, ASC(MID$(MKL$(Divisor), 2, 1)) ' Старший байт
END SUB
REM $STATIC
SUB TimerClose
' Сбрасываем делитель в дефолт
OUT &H43, &H36 ' Управляющий регистр
OUT &H40, 0 ' Младший байт
OUT &H40, 0 ' Старший байт
RestoreVec 8
END SUB
SUB TWnd (x AS LONG, y AS LONG, x2 AS LONG, y2 AS LONG, Cv AS LONG)
DIM i AS LONG
DIM C1 AS LONG, C2 AS LONG
C1 = Cv AND 15: C2 = Cv \ 16
IF (x2 - x > 0) AND (y2 - y > 0) THEN
FOR i = x + 1 TO x2 - 1
Symb i, y, 196, C1, C2
Symb i, y2, 196, C1, C2
NEXT
FOR i = y + 1 TO y2 - 1
Symb x, i, 179, C1, C2
Symb x2, i, 179, C1, C2
NEXT
Symb x, y, 218, C1, C2 ' Лев верх
Symb x2, y, 191, C1, C2 ' Прав верх
Symb x, y2, 192, C1, C2 ' Лев низ
Symb x2, y2, 217, C1, C2 ' Прав низ
END IF
END SUB |
(
Сообщение от Quiet Snow
