home *** CD-ROM | disk | FTP | other *** search
/ Prima Shareware 3 / DuCom_Prima-Shareware-3_cd1.bin / PROGRAMO / PASCAL / KTOOLS / KTOOLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-03-31  |  43.5 KB  |  1,263 lines
  1. {$R-,S-,I+,D+,T+,F-,V-,B-,N-,L+ }
  2. UNIT KTOOLS;{ver 3.0}
  3.  
  4. INTERFACE
  5. USES
  6.     Dos,
  7.     Crt;
  8.  
  9. TYPE
  10.     Colors       = 0..15;
  11.     MenuItemType = String[30];
  12.     MenuDescType = String[80];
  13.     ScrType      = Array[1..4004] OF Byte;
  14.     SaveScrType  = ^ScrType;
  15.     BorderType   = Record
  16.                       TL,TR,BL,BR,FH,FV : Char;
  17.                    End;
  18.     AllFiles=ARRAY[1..500] of String[12];
  19.  
  20. CONST
  21.       Border1 : BorderType = (TL:'╔';TR:'╗';BL:'╚';BR:'╝';FH:'═';FV:'║');
  22.       Border2 : BorderType = (TL:'╒';TR:'╕';BL:'╘';BR:'╛';FH:'═';FV:'│');
  23.       Border3 : BorderType = (TL:'┌';TR:'┐';BL:'└';BR:'┘';FH:'─';FV:'│');
  24.       Border4 : BorderType = (TL:'░';TR:'░';BL:'░';BR:'░';FH:'░';FV:'░');
  25.       Border5 : BorderType = (TL:'▓';TR:'▓';BL:'▓';BR:'▓';FH:'▓';FV:'▓');
  26.  
  27. VAR
  28.     ActiveDP  : Byte;     (* Aktivni stranka displeje          *)
  29.     LineWidth : Integer;  (* Sirka cary aktualniho video modu  *)
  30.     VideoMode : Byte;     (* Aktualni video mod t.j. 0,1,2,3,7 *)
  31.     ErrorCode : Integer;  (* Globalni promenna typu integer pro
  32.                              osetreni chyb    *)
  33.  
  34. FUNCTION CurrentVideoMode : Byte;
  35. (*
  36. Tato funkce vraci aktualni video mod ... 0..3 = barva, 7 = mono.
  37. Globalni promenne LineWidth & ActiveDP jsou nastaveny pokazde,
  38. kdyz je tato funkce volana.
  39. *)
  40.  
  41. PROCEDURE CursorOn;
  42. (*
  43. Tato procedura detekuje aktualni video mod a obnovuje normalni kurzor.
  44. *)
  45.  
  46. PROCEDURE CursorOff;
  47. (*
  48. Tato procedura nastavuje paty bit ridiciho bytu pro kurzor, pricemz
  49. kurzor zmizi.
  50. *)
  51.  
  52. FUNCTION KUCase(S:String):String;
  53. (*
  54. Tato funkce pouziva proceduru upcase ke zkonvertovani celeho retezce
  55. nebo radku z textoveho souboru na velka pismena.
  56. *)
  57.  
  58. FUNCTION KLCase(S:String):String;
  59. (*
  60. Tato funkce pouziva CHR & ORD a ma opacnou funkci jako KUCase.
  61. *)
  62.  
  63. FUNCTION Color(FG,BG:Colors):Byte;
  64. (*
  65. Tato funkce vraci atribut barvy (popredi na pozadi).
  66. Bit pro blikani je odstranen.
  67. *)
  68.  
  69. PROCEDURE KAttr(Row,Col,Rows,Cols:Integer;Attr:Byte);
  70. (*
  71. Tato procedura zapise specifikovany atribut od Row/Col do Cols/Rows.
  72. *)
  73.  
  74. PROCEDURE KFill(Row,Col,Rows,Cols:Integer;Ch:Char;Attr:Byte);
  75. (*
  76. Tato procedura zapise specifikovany znak od Row/Col do Cols/Rows.
  77. *)
  78.  
  79. PROCEDURE KTrim(VAR S:String);
  80. (*
  81. Tato procedura odstrani vsechny nevyznamne mezery z retezce.
  82. (Na zacatku a na konci retezce.)
  83. *)
  84.  
  85. PROCEDURE KWrite(Row,Col:Integer;Attr:Byte;S:String);
  86. (*
  87. Tato procedura zapise retezec na pozici Row/Col s text Attr.
  88. Pouziva aktualni param ze zasobniku.
  89. *)
  90.  
  91. PROCEDURE KWriteV(Row,Col:Integer;Attr:Byte;VAR S:String);
  92. (*
  93. Tato procedura zapise retezec na pozici Row/Col s text Attr.
  94. Pouziva param adress ze zasobniku.
  95. *)
  96.  
  97. PROCEDURE KWriteC(Row:Integer;Attr:Byte;S:String);
  98. (*
  99. Tato procedura zapise retezec na pozici Row/Col s text Attr.
  100. Vystup je centovan na obrazovce mezi radky 1 a 80.
  101. *)
  102.  
  103. PROCEDURE KWriteCV(Row:Integer;Attr:Byte;VAR S:String);
  104. (*
  105. Tato procedura zapise retezec na pozici Row/Col s text Attr.
  106. Vystup je centovan na obrazovce mezi radky 1 a 80.
  107. Pouziva param adress ze zasobniku.
  108. *)
  109.  
  110.  
  111. FUNCTION ReadPen:Integer;
  112. (*
  113. Tato funkce cte aktualni pozici svetelneho pera pokud bylo aktivovano
  114. a hodnotu jako integer.
  115. *)
  116.  
  117. FUNCTION PenPosition(Row,Col:Byte):Integer;
  118. (*
  119. Tato funkce vraci integer z radku/sloupce (Row/Col) ktera koresponduje
  120. s hodnotou, kterou vraci ReadPen.
  121. *)
  122.  
  123. FUNCTION PenRow(Pen_Position:Integer):Byte;
  124. (*
  125. Tato funkce vraci radek z integerove hodnoty Pen_Position.
  126. *)
  127.  
  128. FUNCTION PenCol(Pen_Position:Integer):Byte;
  129. (*
  130. Tato funkce vraci sloupec z integerove hodnoty Pen_Position.
  131. *)
  132.  
  133. (*
  134.    POZNAMKA: Uziti rutin pro svetelne pero;
  135.  
  136.    ReadPen :
  137.              Vraci pozici vybranou svetelnym perem, jeslize bylo s.pero
  138.              aktivovano. Jinak ReadPen vraci 0. Integerova hodnota obsahuje
  139.              prislusny radek v vyssim bytu a prislusny sloupec v nizsím bytu.
  140.  
  141.    PenPosition :
  142.              Tato rutina je pouzitelna pro vypocet integerove hodnoty
  143.              ze zadaneho radku a sloupce. Vypoctena hodnota muze byt
  144.              porovnavana s hodnotou vracenou funkci ReadPen a pouzita
  145.              k dalsimu rizeni behu programu.
  146.  
  147.    PenRow  : Vraci akt. radek z integerove hodnoty Pen_Position.
  148.  
  149.    PenCol  : Vraci akt. sloupec z integerove hodnoty Pen_Position.
  150.  
  151. *)
  152.  
  153.  
  154. PROCEDURE KSaveScr(ULRow,ULCol,Rows,Cols : Byte;
  155.                    VAR Dest_Variable : SaveScrType);
  156. (*
  157. Tato procedura uschova obsah oblasti obrazovky mezi ULRow/ULCol a
  158. Rows/Cols do promenne Dest_Variable. Prvni ctyri byty promenne
  159. Dest_Variable obsahuji 1)ULRow 2)ULCol 3)Rows 4)Cols, takze obrazovka
  160. je jednoduse obnovena volanim KRestoreScr(Source_Variable);
  161. *)
  162.  
  163. PROCEDURE KRestoreScr(Source_Variable : SaveScrType);
  164. (*
  165. Tato procedura obnovuje obrazovku, k cemuz pouziva obsah promenne
  166. Source_Variable. Prvni ctyri byty obsahuji popis oblasti obrazovky, kam
  167. ma byt Source_Variable ulozena.
  168. *)
  169.  
  170.  
  171. PROCEDURE KBox (ULRow,ULCol,Rows,Cols: Integer;
  172.                 FrameAttr,WindowAttr : Byte;
  173.                 Border               : BorderType;
  174.                 ClearWindow          : Boolean);
  175. (*
  176. Tato procedura namaluje ramecek pouzivajici jeden z peti typu okraje.
  177. Barvy popredi a pozadi musi byt zadany stejne jako barva aktualniho
  178. okna. ClearWindow je vlajka pro vymazani okna pouzitim WindowAttr
  179. s mezerami nebo pro ponechani vnitrku okna. Jestlize okno neni vymazano,
  180. je text. atribut okna nezmenen.
  181. *)
  182.  
  183. FUNCTION KVertMenu(Selection_Start : INTEGER; {vyber v menu pri jeho vyvolani  }
  184.                    VAR MenuList;               {seznam polozek menu            }
  185.                    MenuItemTotal,              {celkovy pocet polozek menu     }
  186.                    XStart,                     {pocatecni pozice - sloupec     }
  187.                    YStart,                     {poc. pozice - radek            }
  188.                    XHiliteStart,               {zvyrazneny pocet sloupcu       }
  189.                    LengthOfHilite,             {pocet sloupcu pro zvyrazneni   }
  190.                    NormalAttr,                 {normalni text atribut pro menu }
  191.                    HiliteAttr :                {atribut zvyraznene polozky     }
  192.                    INTEGER):INTEGER;           {funkce vraci integerovou hodnotu}
  193. (*
  194. Tato procedura pouziva pole polozek type menuitemtype a vygeneruje vertikalni
  195. menu slozene z techto polozek. Vraci zvolenou polozku jako hodnotu integer.
  196. MenuList je promena bez uvedeni typu, ktera je pristupna procedure pomoci
  197. prikazu Absolute.
  198. *)
  199.  
  200. FUNCTION KHorizMenu(Selection_Start:INTEGER; {vyber v menu pri jeho vyvolani }
  201.                     VAR MenuList,            {seznam polozek menu            }
  202.                         MenuDesc;            {popis kazde polozky            }
  203.                     MenuItemTotal,           {celkovy pocet polozek menu     }
  204.                     MenuWindowWidth,         {pocet sloupcu pro menu         }
  205.                     XStart,                  {pocatecni pozice - sloupec     }
  206.                     YStart,                  {poc. pozice - radek            }
  207.                     NormalAttr,              {normalni text atribut pro menu }
  208.                     HiliteAttr,              {atribut zvyraznene polozky     }
  209.                     DescAttr:                {barva pro popis                }
  210.                     INTEGER):INTEGER;        {funkce vraci hodnotu integer   }
  211.  
  212. (*
  213. Tako procedura pouziva pole polozek typu menuitemtype a generuje horizontalni
  214. menu z techto polozek spolu se zvolenym popisem kazde polozky. Funkce vraci
  215. cislo volby - integerovou hodnotu. MenuList je promenna bez uvedeni typu,
  216. ktera je procedure pristupna prikazem Absolute.
  217. *)
  218.  
  219. PROCEDURE  CopyFile(Input_File,           {filename.ext souboru pro kopirovani}
  220.                     Output_File           {filename.ext vytvareneho souboru   }
  221.                                :String;
  222.                     VAR Return_Code       {DOS error - kod chyby DOSu         }
  223.                                :Integer;
  224.                     EraseInputFile:Boolean);
  225. (*
  226. Tato procedura zkopiruje Input_File do souboru vytvoreneho jako OutPut_File.
  227. Toto je "aktualni kopie", proto jmena souboru nemohou byt stejna. Funkce
  228. prejmenovani je podporovana primo DOSem, ktera prejmenuje soubor a soucasne
  229. odstrani stary soubor. Proto, kdyz je "EraseInputFile" = true, pouzijeme
  230. DOSovou funkci ke zkopirovani souboru "do" jeho noveho jmena. Jestlize
  231. je "EraseInputFile" = false, pak je DOSova funkce vynechana a my muzeme
  232. jednoduse provest zkopirovani.
  233. *)
  234.  
  235.  
  236. FUNCTION IntToHex(IntNum:Integer):String;
  237. (*
  238. Tato funkce konvertuje integerovou hodnotu na hexadecimalni, ktera je
  239. reprezentovana typem string.
  240. *)
  241.  
  242.  
  243. FUNCTION Space(Number:Integer):String;
  244. (*
  245. Tato funkce vraci promennou typu String, ve ktere je zadany
  246. pocet {Number} mezer.
  247. *)
  248.  
  249.  
  250. PROCEDURE DirFill(VAR Path:String;      {deklarovana cesta pro hledani}
  251.                   VAR Files:AllFiles;   {pole vsech souboru v direktorari}
  252.                   VAR Counter:Integer; {celkovy pocet souboru v direktorari}
  253.                   IncludeDirListings:Boolean);
  254. (*
  255. Dana cesta pro prohledavani v Path je pole polozek typu Allfiles je
  256. vlozena do promenne FILES. V COUNTER je pocet platnych vstupu - celkovy
  257. pocet souboru obsazenych ve FILES. Jestlize INCLUDEDIRLISTLINGS = true,
  258. pak vsechny adresare v predane ceste budou vlozeny do pole a mohou byt
  259. vybrany.
  260. *)
  261.  
  262. PROCEDURE SortDir(VAR Files:AllFiles;   {pole vsech souboru v adresari}
  263.                   VAR Counter:Integer); {pocet souboru, ktere chcete tridit}
  264.                                         {do celk. poctu souboru}
  265. (*
  266. Tato procedura setridi podle jmena soubory, jejichz pocet je uveden
  267. v Counter. Muzete tridit max. 500 souboru - pole ALLFILES ma max. pocet
  268. polozek 500.
  269. *)
  270.  
  271.  
  272. FUNCTION PIKDIR(Path:String;IncludeDir:Boolean):String;
  273. (*
  274. Funkce vraci cestu/soubor v PIKDIR. Cesta je specifikovana v PATH.
  275. Jestlize INCLUDEDIR = true, pak je mozno vybrat soubor ze vsech pristupnych
  276. adresaru. Jestlize INCLUDEDIR=false. pak lze vybrat pouze ze souboru
  277. nachazejicich se v PATH.
  278.  
  279. POZN. : PIKDIR vraci kompletni cestu+soubor. Nevrati cestu bez uvedeni
  280. souboru.
  281. *)
  282.  
  283.  
  284. IMPLEMENTATION
  285. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  286.  
  287. FUNCTION CurrentVideoMode:Byte;
  288. VAR
  289.     Regs:Registers;               {Registry definovane v jednotce DOS}
  290. BEGIN
  291.     Regs.AH := $F;
  292.     Intr($10,Regs);
  293.     CurrentVideoMode:=Regs.AL;    {Prirazeni video modu ke jmenu funkce}
  294.     ActiveDP:=Regs.BH;            {Aktivni stranka}
  295.     LineWidth:=Regs.AH;           {Pocet znaku na radek}
  296. END;
  297. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  298.  
  299. PROCEDURE CursorOn;
  300. VAR
  301.     Regs:Registers;               {Registry definovane v jednotce DOS}
  302.     Mode:Byte;
  303. BEGIN
  304.     Mode := CurrentVideoMode;     {aktualni video mod}
  305.     IF Mode IN[0..3] THEN
  306.        BEGIN
  307.           Regs.AH := $01;                { Obnoveni barevneho kurzoru }
  308.           Regs.CH := $06;
  309.           Regs.CL := $07;
  310.           Intr($10,Regs);
  311.        END
  312.     ELSE
  313.        IF Mode = 7 THEN
  314.           BEGIN
  315.              Regs.AH := $01;            { Obnoveni monochrom. kurzoru }
  316.              Regs.CH := $C;
  317.              Regs.CL := $D;
  318.              Intr($10,Regs);
  319.           END
  320.        ELSE
  321.           BEGIN
  322.              Regs.AH := $01;            { Zobrazeni kurzoru ve tvaru }
  323.              Regs.CH := $1;             { bloku,jestlize }
  324.              Regs.CL := $D;             { vsechno selhalo }
  325.              Intr($10,Regs);
  326.           END;
  327.  
  328. END;
  329. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  330.  
  331. PROCEDURE CursorOff;
  332. VAR
  333.    Regs:Registers;
  334. BEGIN                            { Nastaveni bitu 5 ridiciho bytu kurzoru }
  335.    Regs.AH := $01;               { coz zhasne kurzor        }
  336.    Regs.CH := $20;
  337.    Intr($10,Regs);
  338. END;
  339. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  340.  
  341. FUNCTION KUCase(S:String):String;
  342. VAR
  343.    I: integer;
  344. BEGIN
  345.    FOR I := 1 TO Length(S) DO S[I] := UpCase(S[I]);
  346.    KUCase := S;
  347. END;
  348. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  349.  
  350. FUNCTION KLCase(S:String):String;
  351. VAR
  352.    I: integer;
  353. BEGIN
  354.    FOR I := 1 TO Length(S) DO
  355.       IF S[I] IN['A'..'Z'] THEN   {If character is A-Z }
  356.          S[I]:=CHR(ORD(S[I])+$20);{Pridani HEX 20 pro mala pismena}
  357.    KLCase := S;
  358. END;
  359. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  360.  
  361. FUNCTION Color(FG,BG:Colors):Byte;
  362. BEGIN
  363.    Color := (FG+(BG SHL 4)) MOD 128;{posunuti pozadi o ctyri bity doleva}
  364.                                     { a pridani popredi MOD 128}
  365. END;                                {MOD 128 odstrani blikani}
  366. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  367.  
  368. PROCEDURE KAttr(Row,Col,Rows,Cols:Integer;Attr:Byte);
  369. VAR
  370.     Ch,X,Y,R,C:Integer;
  371.     Regs:Registers;
  372. BEGIN
  373.    R:=(Row+(Rows-1));
  374.    C:=(Col+(Cols-1));
  375.    REPEAT
  376.       X:=Col;
  377.          REPEAT
  378.                GOTOxy(x,Row);              {volani BIOSu - precteni znaku}
  379.                Regs.AH:=$08;               {a attributu                  }
  380.                Regs.BH:=ActiveDP;          {Specifikace aktivni stranky  }
  381.                Intr($10,Regs);
  382.  
  383.                { Regs.AL obsahuje znak precteny sluzbou 8}
  384.  
  385.                Regs.AH:=$09;             {volaniBIOS pro zapsani znaku}
  386.                                          {a tributu na obrazovku}
  387.                Regs.BH:=ActiveDP;        {specifikace aktivni stranky}
  388.                Regs.BL:=Attr;            {specifikace atributu }
  389.                Regs.CX:=$01;             {zapis jednou}
  390.                Intr($10,Regs);
  391.                X:=X+1;                   {INC X t.j. pozice sloupce}
  392.          UNTIL X>C;
  393.       Row:=Row+1;                        {INC Row t.j. pozice radku}
  394.    UNTIL Row > R;
  395. END;
  396. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  397.  
  398. PROCEDURE KFill(Row,Col,Rows,Cols:Integer;Ch:Char;Attr:Byte);
  399. VAR
  400.     R:Integer;
  401.     Regs:Registers;
  402.  
  403. (**)
  404.  
  405. BEGIN
  406.    R:=(Row+(Rows-1));
  407.    REPEAT
  408.       GOTOxy(col,Row);
  409.       Regs.AH:=$09;
  410.       Regs.AL:=ORD(Ch);
  411.       Regs.BH:=ActiveDP;
  412.       Regs.BL:=Attr;
  413.       Regs.CX:=cols;
  414.       Intr($10,Regs);
  415.       Row:=Row+1;
  416.    UNTIL Row > R;
  417. END;
  418.  
  419. (*
  420.  
  421. { Jestlize nechcete pouzivat volani BIOSu, odstrante komentarove zavorky
  422. a znovu zkompilujte. }
  423.  
  424.     S : String;
  425.     SavedTextAttr:Integer;
  426.  
  427. BEGIN
  428.    S:='';
  429.    FOR X := 1 to Cols DO
  430.       S:=S+Ch;
  431.    R:=(Row+(Rows-1));
  432.    SavedTextAttr:=CRT.TextAttr;
  433.    CRT.TextAttr:=Attr;
  434.    REPEAT
  435.          GOTOxy(Col,Row);
  436.          Write(s);
  437.          Row:=Row+1;
  438.    UNTIL Row > R;
  439.    CRT.TextAttr:=SavedTextAttr
  440. END;
  441. *)
  442.  
  443. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  444.  
  445. PROCEDURE KTrim(VAR s : string);
  446. VAR
  447.     x,b,e : Integer;
  448. BEGIN
  449.     For X := 1 to LENGTH(s) DO
  450.        IF s[1]=' ' THEN DELETE(S,1,1); {odstraneni nevyznamnych mezer}
  451.     b:=1;
  452.     e:=ORD(s[0]);
  453.     REPEAT
  454.        IF s[e] = ' ' THEN DELETE(S,e,1);
  455.        DEC(e);
  456.     UNTIL s[e] <> ' ';
  457.  
  458. END;
  459. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  460.  
  461. (*
  462.    Nasledujici procedury nepouzivaji volani BIOSu. TEXTATTR je v jednotce
  463.    CRT a obsahuje atribut aktualni video stranky a potrebnou pozici znaku.
  464.    Proto ho uschovame pred nasim zapisem na obrazovku. Centrovani textu
  465.    je provedeno odectenim delky retezce od LineWidth a vydelenim 2.
  466.    Timto zpusobem ziskame pocatecni sloupec.
  467. *)
  468.  
  469. PROCEDURE KWrite(Row,Col:Integer;Attr:Byte;S:String);
  470. VAR
  471.     SavedTextAttr:Integer;
  472. BEGIN
  473.     SavedTextAttr:=CRT.TextAttr;
  474.     CRT.TextAttr:=Attr;
  475.     GotoXY(Col,Row);
  476.     Write(s);
  477.     CRT.TextAttr:=SavedTextAttr
  478. END;
  479. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  480.  
  481. PROCEDURE KWriteV(Row,Col:Integer;Attr:Byte;VAR S:String);
  482. VAR
  483.     SavedTextAttr:Integer;
  484. BEGIN
  485.     SavedTextAttr:=CRT.TextAttr;    {Zapis aktualni textattr}
  486.     CRT.TextAttr:=Attr;             {Prirad noovy atribut}
  487.     GotoXY(Col,Row);                {Presun kurzor na pocatecni pozici}
  488.     Write(s);                       {Zapiz retezec a atribut}
  489.     CRT.TextAttr:=SavedTextAttr;     {Obnov puvodni textattr}
  490.  
  491. END;
  492. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  493.  
  494. PROCEDURE KWriteC(Row:Integer;Attr:Byte;S:String);
  495. VAR
  496.     X,SavedTextAttr:Integer;
  497. BEGIN
  498.     SavedTextAttr:=CRT.TextAttr;
  499.     CRT.TextAttr:=Attr;
  500.     X:=(LineWidth-Length(S)) DIV 2; {centrovani}
  501.     GotoXY(X,Row);
  502.     Write(s);
  503.     CRT.TextAttr:=SavedTextAttr
  504. END;
  505. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  506.  
  507. PROCEDURE KWriteCV(Row:Integer;Attr:Byte;VAR S:String);
  508. VAR
  509.     X,SavedTextAttr:Integer;
  510. BEGIN
  511.     SavedTextAttr:=CRT.TextAttr;
  512.     CRT.TextAttr:=Attr;
  513.     X:=(LineWidth-Length(S)) DIV 2;
  514.     GotoXY(X,Row);
  515.     Write(s);
  516.     CRT.TextAttr:=SavedTextAttr
  517. END;
  518. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  519.  
  520. FUNCTION ReadPen:Integer;
  521. VAR Regs : Registers;
  522. BEGIN
  523.    Regs.AH := 4;
  524.    Intr($10,Regs);
  525.    IF Regs.AH = 1 THEN ReadPen := Regs.DX;
  526. END;
  527. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  528.  
  529. FUNCTION PenPosition(Row,Col:Byte):Integer;
  530. BEGIN
  531.    PenPosition := (Row SHL 8)+Col;
  532. END;
  533. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  534.  
  535. FUNCTION PenRow(Pen_Position:Integer):Byte;
  536. BEGIN
  537.    PenRow := Hi(Pen_Position);
  538. END;
  539. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  540.  
  541. FUNCTION PenCol(Pen_Position:Integer):Byte;
  542. BEGIN
  543.    PenCol := Lo(Pen_Position);
  544. END;
  545. (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  546.  
  547. PROCEDURE KSaveScr(ULRow,ULCol,Rows,Cols : Byte;
  548.                    VAR Dest_Variable : SaveScrType);
  549. VAR
  550.     Ch,X,Y,R,C,Counter:Integer;
  551.     Regs:Registers;
  552. BEGIN
  553.    R:=(ULRow+(Rows-1));
  554.    C:=(ULCol+(Cols-1));
  555.    Dest_Variable^[1]:=ULRow;     {Zapis Ystart,Xstart, pocet radku}
  556.    Dest_Variable^[2]:=ULCol;     {a pocet sloupcu do prvych ctyrech bytu}
  557.    Dest_Variable^[3]:=Rows;      {promenne}
  558.    Dest_Variable^[4]:=Cols;
  559.    Counter := 5; {Nastav pocitadlo(counter) na prvni byte
  560.                   informace o obrazovce}
  561.    REPEAT
  562.       X:=ULCol;
  563.          REPEAT
  564.                GOTOxy(x,ULRow);
  565.                Regs.AH:=$08;     {cislo sluzby BIOSu}
  566.                Regs.BH:=ActiveDP;{aktivni stranka displeje}
  567.                Intr($10,Regs);   {preruseni}
  568.                Dest_Variable^[Counter]:=Regs.AL; {pecteni znaku}
  569.                INC(Counter);
  570.                Dest_Variable^[Counter]:=Regs.AH; {precteni atributu}
  571.                INC(Counter);
  572.                INC(X);                   {INC X t.j. pozice sloupce}
  573.          UNTIL X>C;
  574.       INC(ULRow);                          {INC Row t.j. pozice radku}
  575.    UNTIL ULRow > R;
  576. END;
  577. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  578.  
  579. PROCEDURE KRestoreScr(Source_Variable : SaveScrType);
  580. VAR
  581.     Ch,X,Y,R,C,
  582.     Row,Col,Counter:Integer;
  583.     Regs:Registers;
  584. BEGIN
  585.    R:=(Source_Variable^[1]+(Source_Variable^[3]-1));
  586.    C:=(Source_Variable^[2]+(Source_Variable^[4]-1));
  587.    Row := Source_Variable^[1];
  588.    Col := Source_Variable^[2];
  589.    Counter := 5;
  590.    REPEAT
  591.       X:=Col;
  592.          REPEAT
  593.                GOTOxy(x,Row);    {volani BIOSu pro cteni znaku z obraz.}
  594.                Regs.AH:=$09;
  595.                Regs.AL:=Source_Variable^[Counter]; {Specifikace znaku}
  596.                INC(Counter);
  597.                Regs.BL:=Source_Variable^[Counter]; {Specifikace atributu}
  598.                INC(Counter);
  599.                Regs.BH:=ActiveDP;        {Specifikace aktivni stranky}
  600.                Regs.CX:=$01;             {zapis jednou}
  601.                Intr($10,Regs);
  602.                INC(X);                   {INC X t.j. pozice sloupce}
  603.          UNTIL X>C;
  604.       INC(Row);                        {INC Row t.j. pozice radku}
  605.    UNTIL Row > R;
  606. END;
  607. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  608.  
  609. PROCEDURE KBox (ULRow,ULCol,Rows,Cols: Integer;
  610.                 FrameAttr,WindowAttr : Byte;
  611.                 Border               : BorderType;
  612.                 ClearWindow          : Boolean);
  613. VAR
  614.    Y,Wh,Wl,H,L : Integer;
  615. BEGIN
  616.   IF (Rows>=2) AND (Cols>=2) THEN     {box nemuze byt mensi nez 2x2}
  617.   BEGIN
  618.     L:=Lo(WindMin);H:=Hi(WindMin);
  619.     Wl:=Lo(WindMax);Wh:=Hi(WindMax);
  620.     WindMax:=(25 SHL 8)+Wl; {can go past last row by 1 row }
  621.     WITH Border DO
  622.     BEGIN
  623.       KWrite(ULRow,ULCol,FrameAttr,TL);           {levy horni roh}
  624.       KFill(ULRow,ULCol+1,1,Cols-2,FH,FrameAttr); {horiz. cara}
  625.       KWrite(ULRow,ULCol+Cols-1,FrameAttr,TR);    {pravy horni roh}
  626.       FOR Y := ULRow+1 TO ULRow+Rows-2 DO
  627.         BEGIN
  628.           KWrite(Y,ULCol,FrameAttr,FV);        {vertikalni cara}
  629.           KWrite(Y,ULCol+Cols-1,FrameAttr,FV); {na obou stranach}
  630.         END;
  631.       KWrite(ULRow+Rows-1,ULCol,FrameAttr,BL);           {levy dolni roh}
  632.       KFill(ULRow+Rows-1,ULCol+1,1,Cols-2,FH,FrameAttr); {horiz. cara}
  633.       KWrite(ULRow+Rows-1,ULCol+Cols-1,FrameAttr,BR);    {pravy dolni roh}
  634.  
  635.       IF ClearWindow THEN     {vymaz okno}
  636.       KFill (ULRow+1,ULCol+1,Rows-2,Cols-2,' ',WindowAttr);
  637.  
  638.       WindMax:=(Wh SHL 8)+Wl; {obnov dolni roh okna}
  639.       Window(L,H,Wl,Wh);      {obnov puvodni obraz. okna}
  640.       GOTOxy(1,1);
  641.     END
  642.   END
  643. END;
  644.  
  645. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  646.  
  647. FUNCTION KVertMenu(Selection_Start : INTEGER; {pocatecni vyber pri volani
  648.                                                funkce}
  649.                   VAR MenuList;               {seznam polozek menu   }
  650.                   MenuItemTotal,              {celkovy pocet polozek menu }
  651.                   XStart,                     {poc.pozice - sloupec    }
  652.                   YStart,                     {poc.pozice - radek      }
  653.                   XHiliteStart,               {zvyrazneny poc. pocet sloupcu}
  654.                   LengthOfHilite,             {pocet sloupce pro zvyrazneni }
  655.                   NormalAttr,                 {text atribut pro menu }
  656.                   HiliteAttr :                {atribut zvyraznene polozky  }
  657.                   INTEGER):INTEGER;           {funkce vraci hodnotu integer}
  658.  
  659.  
  660. VAR
  661.    Menu : Array[1..2] OF MenuItemType absolute MenuList;
  662.    SelectionMade : Boolean;
  663.    X,Y : INTEGER;
  664.    Row,Col,Rows,Cols,
  665.    Choice : INTEGER;
  666.    Ch : Char;
  667.  
  668. BEGIN
  669.    Col := XHiliteStart;
  670.    Rows := 1;
  671.    Cols := LengthOfHilite;
  672.    Choice := Selection_Start;
  673.    FOR y := 0 to MenuItemTotal-1 DO   {zapis seznam polozek menu}
  674.       KWrite(YStart+y,XStart,NormalAttr,Menu[y+1]);
  675.    Row := YStart+Selection_Start-1;  {pozice radku pro prvni zvyrazneni}
  676.    KAttr(Row,Col,Rows,Cols,HiliteAttr);
  677.    SelectionMade := False;   {nebyl jeste proveden vyber}
  678.  
  679.    REPEAT
  680.       Ch := ReadKey;
  681.       IF Ch = #13 THEN  { stlacen ENTER }
  682.          BEGIN
  683.             KVertMenu := Choice;  {prirazeni vasi volby do KVertmenu }
  684.             SelectionMade := True;   {byl proveden vyber}
  685.          END
  686.       ELSE
  687.          IF Ch = #27 THEN  { stlacena klavesa ESCAPE }
  688.             BEGIN
  689.                KVertMenu := 0; { prirad KVertMenu 0 protoze neni nulta polozka}
  690.                EXIT;
  691.             END
  692.          ELSE
  693.             IF Ch = #0 Then    { pokud ch = 0 pak se jedna o "rozsirenou"
  694.                                  klavesu }
  695.                Ch := ReadKey;
  696.       CASE Ch OF
  697.  
  698.          #72 : BEGIN  {sipka nahoru}
  699.                   KAttr(Row,Col,Rows,Cols,NormalAttr);
  700.                   IF Choice = 1 THEN BEGIN
  701.                                         Choice := MenuItemTotal;
  702.                                         Row    := Ystart+MenuItemTotal-1;
  703.                                      END
  704.                   ELSE
  705.                                      BEGIN
  706.                                         Choice := Choice-1;
  707.                                         Row    := Row-1;
  708.                                      END;
  709.                   KAttr(Row,Col,Rows,Cols,HiliteAttr);
  710.                END;
  711.          #80 : BEGIN  {DOWN arrow}
  712.                   KAttr(Row,Col,Rows,Cols,NormalAttr);
  713.                   IF Choice = MenuItemTotal THEN BEGIN
  714.                                         Choice := 1;
  715.                                         Row    := Ystart;
  716.                                      END
  717.                   ELSE
  718.                                      BEGIN
  719.                                         Choice := Choice+1;
  720.                                         Row    := Row+1;
  721.                                      END;
  722.                   KAttr(Row,Col,Rows,Cols,HiliteAttr);
  723.                END;
  724.       END;
  725.    UNTIL SelectionMade;
  726. END;
  727. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  728. FUNCTION KHorizMenu(Selection_Start:INTEGER; {zvyraznena polozka pri volani  }
  729.                     VAR MenuList,            {seznam polozek menu            }
  730.                         MenuDesc;            {popis kazde polozky            }
  731.                     MenuItemTotal,           {celkovy pocet polzek           }
  732.                     MenuWindowWidth,         {pocet sloupcu pro menu         }
  733.                     XStart,                  {pocatecni pozice - sloupec     }
  734.                     YStart,                  {pocatecni pozice - radek       }
  735.                     NormalAttr,              {normalni text atribut pro menu }
  736.                     HiliteAttr,              {atribut zvyraznene polozky     }
  737.                     DescAttr:                {barva pro popis                }
  738.                     INTEGER):INTEGER;        {funkce vraci hodnotu integer   }
  739.  
  740. VAR
  741.    Menu : Array[1..2] OF MenuItemType absolute MenuList;
  742.    Desc : Array[1..2] OF MenuDescType absolute MenuDesc;
  743.  
  744.    (*
  745.       MenuDescType je definovano jako String[80], jelikoz vase poznamka muze
  746.       byt 80 znaku dlouha. Je ve vasem zajmu, zda-li se poznamka vejde do vami
  747.       specifikovaneho MenuWindowWidth(sirka okna pro menu).
  748.    *)
  749.  
  750.    MPos : Array[1..25] OF Integer;            {pozice pro kazdou polozku}
  751.    PageBreak : Array[1..10,0..1] OF Integer;  {pocatecni a konecny pocet
  752.                                                polozek na strance}
  753.  
  754.    SelectionMade : Boolean;
  755.    X,Y,Space,Page,
  756.    Row,Col,
  757.    Choice,TotalX,
  758.    Position,MaxPage : INTEGER;
  759.    Ch : Char;
  760.  
  761.  
  762. FUNCTION MenuItemLength(A:Integer):Integer; { delka polozky }
  763. BEGIN
  764.   MenuItemLength := ORD(Menu[A][0]);
  765. END;
  766.  
  767. FUNCTION MenuDescLength(A:Integer):Integer; { delka poznamky }
  768. BEGIN
  769.   MenuDescLength := ORD(Desc[A][0]);
  770. END;
  771.  
  772. BEGIN (* KHorizMenu *)
  773.    Row    := YStart;
  774.    Col    := XStart;
  775.    Space  := 3;      { roztec mezi polozkami }
  776.    Page   := 1;      { definice prvni stranky a  Max Page ackolli }
  777.    MaxPage := 1;     { je lze zmenit na kratsi }
  778.    TotalX := XStart; { TotalX je stradac }
  779.    Position := Selection_Start; { preddef. pozice polozky }
  780.    SelectionMade := False;   { zatim zadna nevybrana }
  781.    PageBreak[MaxPage][0] := 1;  { zaciname s polozkou 1 na strance 1 }
  782.  
  783.    FOR X := 1 TO MenuItemTotal DO
  784.       BEGIN
  785.          IF ( (TotalX-XStart)+MenuItemLength(X) > MenuWindowWidth ) THEN
  786.             BEGIN                              { Jestlize prekrocime nasi
  787.                                                  sirku okna }
  788.                PageBreak[MaxPage][1] := X-1; {nastav aktualni konec stranky}
  789.                INC(MaxPage);                 {zvys stranku o 1}
  790.                PageBreak[MaxPage][0] := X;   {nastav novy zacatek stranky}
  791.                TotalX := XStart;             {znovu nastav akumulator }
  792.                MPos[X] := TotalX;            {prirad pozici na obrazovce }
  793.             END
  794.          ELSE
  795.             MPos[X] := TotalX;    { jinak prirad aktualni totalx do MPos[x]}
  796.  
  797.       IF X = MenuItemTotal THEN       { zajisti posledni page break a }
  798.          PageBreak[MaxPage][1] := X;  { uchovej pocet polozek menu }
  799.  
  800.       IF X = Selection_Start THEN  { srovnej spravnou stranku }
  801.          Page := MaxPage;          { s preddefinovanou volbou }
  802.  
  803.       TotalX  := TotalX+Space+MenuItemLength(X);
  804.       END;
  805.  
  806. WHILE NOT SelectionMade DO
  807. BEGIN
  808.  
  809.    KFIll(Row,XStart,1,MenuWindowWidth,' ',NormalAttr);{vymaz cast polozky
  810.                                                        z okna}
  811.  
  812.    FOR X := PageBreak[Page][0] TO PageBreak[Page][1] DO {skoc pres stranku a}
  813.       BEGIN                                             {zapis polozky      }
  814.          KWrite(Row,MPos[x],NormalAttr,Menu[X]);
  815.       END;
  816.  
  817.    KAttr(Row,MPos[Position],1,MenuItemLength(Position),HiLiteAttr);
  818.                                                    {zvyraznena pozice}
  819.    KWrite(Row+1,XStart,DescAttr,Desc[Position]); {zapis popis polozek}
  820.  
  821.    Choice := Position; {neuzitecna vymena, ale vypada to hezky a ciste}
  822.       Ch := ReadKey;                 {cekej na stisk klavesy}
  823.       IF Ch = #13 THEN               { jestlize ENTER, pak }
  824.          BEGIN
  825.             KHorizMenu := Choice;    {prirad vasi volbu k KHorizMenu}
  826.             SelectionMade := True;   {vyber byl proveden}
  827.          END
  828.       ELSE
  829.          IF Ch = #27 THEN            { jestlize ESCAPE, pak }
  830.             BEGIN
  831.                KHorizMenu := 0; { prirazeni 0 pro KHorizMenu jelikoz
  832.                                   neexistuje nulta polozka}
  833.                EXIT; { ve vasem programu testujte 0= zadna akce }
  834.             END
  835.          ELSE
  836.             IF Ch = #0 Then    { pokud ch = 0 mame rozsirenou klavesu }
  837.                Ch := ReadKey;  { druhe cteni pro rozsirenou klavesu }
  838.  
  839.             CASE Ch OF
  840.                #75 : BEGIN  {left arrow key}
  841.                         KAttr(Row,MPos[Position],1,MenuItemLength(Position),NormalAttr);
  842.                         KFIll(Row+1,XStart,1,MenuDescLength(Position),' ',DescAttr);
  843.  
  844.                         IF (Position = 1) AND (Page = 1) THEN
  845.                            BEGIN
  846.                               Position := MenuItemTotal;
  847.                               Page := MaxPage;
  848.                            END
  849.                         ELSE
  850.                            IF Position = PageBreak[Page][0] THEN
  851.                               BEGIN
  852.                                  DEC(Position);
  853.                                  DEC(Page);
  854.                               END
  855.                            ELSE
  856.                                DEC(Position);
  857.                      END;
  858.  
  859.                #77 : BEGIN  {prava sipka}
  860.                         KAttr(Row,MPos[Position],1,MenuItemLength(Position),NormalAttr);
  861.                         KFIll(Row+1,XStart,1,MenuDescLength(Position),' ',DescAttr);
  862.  
  863.                         IF Position = MenuItemTotal THEN
  864.                            BEGIN
  865.                               Position := 1;
  866.                               Page := 1;
  867.                            END
  868.                         ELSE
  869.                            IF Position = PageBreak[Page][1] THEN
  870.                               BEGIN
  871.                                  INC(Position);
  872.                                  INC(Page);
  873.                               END
  874.                            ELSE
  875.                               INC(Position);
  876.                      END;
  877.       END;
  878. END; {while do}
  879. END;
  880.  
  881. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  882. PROCEDURE SortDir(VAR Files:AllFiles;VAR Counter:Integer);
  883. VAR
  884.    Flag:Boolean;
  885.    X:Integer;
  886.    Temp:String[12];
  887.  
  888. BEGIN
  889.    Flag:=False;
  890.    REPEAT
  891.      Flag:=False;
  892.      FOR X:=2 TO Counter DO {zaciname u dvojky protoze se pouziva vyraz "-1"}
  893.       IF (Files[X][1]='<') AND (Files[X-1][1]<>'<') THEN
  894.               BEGIN
  895.                  Flag:=True;
  896. {swap things}    Temp:=Files[X-1];
  897. {around here}    Files[X-1]:=Files[X];
  898.                  Files[X]:=Temp;
  899.               END
  900.    UNTIL NOT Flag;
  901.    REPEAT
  902.       Flag:=False;
  903.       FOR X:=2 TO Counter DO
  904.           IF (Files[X][1]='<') AND (Files[X-1][1]='<') THEN
  905.              IF Files[X]<Files[X-1] THEN
  906.               BEGIN
  907.                  Flag:=True;
  908.  {ditto}         Temp:=Files[X-1];
  909.                  Files[X-1]:=Files[X];
  910.                  Files[X]:=Temp;
  911.               END
  912.                                     ELSE
  913.                                                         ELSE
  914.            IF (Files[X]<Files[X-1]) AND (Files[X-1][1]<>'<') THEN
  915.              BEGIN
  916.                  Flag:=True;
  917.                  Temp:=Files[X-1];
  918.  {ditto}         Files[X-1]:=Files[X];
  919.                  Files[X]:=Temp;
  920.               END;
  921.    UNTIL NOT Flag;
  922. END;
  923.  
  924.  
  925. (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  926. PROCEDURE DirFill(VAR Path:String;VAR Files:AllFiles;
  927.                   VAR Counter:Integer;IncludeDirListings:Boolean);
  928. VAR
  929.    Attri:Byte;
  930.    SRec:SearchRec;   { searchrec je definovan v jednotce DOS }
  931.  
  932. BEGIN
  933.    Attri:=$3F;  { atributy nejakeho souboru vseobecne }
  934.    Counter:=0;  { nastav stradac na 0 }
  935.    FindFirst(Path,Attri,SRec); { funkce TP, ktera najde prvni soubor}
  936.    IF DosError=0 THEN          {operace bez chyby}
  937.     REPEAT
  938.        IF SRec.Name<>'.' THEN  {ignoruj tecku v adresari}
  939.         BEGIN
  940.  
  941.            IF IncludeDirListings THEN
  942.               BEGIN
  943.                  INC(Counter);       {platny soubor - inkrementace stradace}
  944.                  IF SRec.Attr=Directory THEN
  945.                     Files[Counter]:='<'+SRec.Name+'>' {zapis vstupni bod adresare}
  946.                  ELSE
  947.                     Files[Counter]:=SRec.Name;        {pridej to jako vstup souboru}
  948.               END;
  949.  
  950.            IF NOT IncludeDirListings THEN
  951.               IF SRec.Attr<>Directory THEN
  952.                  BEGIN
  953.                     INC(Counter);       {platny soubor - inkrementace 1}
  954.                     Files[Counter]:=SRec.Name; {pridej to jako vstup souboru}
  955.                  END;
  956.  
  957.         END;
  958.        Attri:=$3F;     {reset searchrec atributu}
  959.        FindNext(SRec); {funkce TP - nejde dalsi soubor}
  960.     UNTIL DosError<>0; {cyklus dokud jsou nejake dalsi soubory}
  961. END;
  962.  
  963.  
  964. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  965. FUNCTION Space(Number:Integer):String;
  966.  
  967. VAR
  968.    X:Integer;
  969.    TempSpace:String;
  970.  
  971. BEGIN
  972.      TempSpace:='';
  973.      FOR X:=1 TO Number DO           {vytvor retezec z mezer}
  974.           TempSpace:=TempSpace+' ';  {od 1 do Number}
  975.      Space:=TempSpace;
  976. END;
  977.  
  978.  
  979. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  980. PROCEDURE CopyFile (Input_File,Output_File:String;
  981.                     VAR Return_Code:integer;EraseInputFile:Boolean);
  982. CONST
  983.    RecordSize = 128;
  984.    RecordNum  = 128;
  985. TYPE
  986.    CopyBuffer = array[1..RecordSize,1..RecordNum] of byte;
  987.  
  988. VAR
  989.    DOS_Return_Code  : Boolean;
  990.    Regs             : Registers;
  991.    FileIn,FileOut   : File;        {promena je bez uvedeni typu polozek}
  992.    CopyBufrPtr      : ^CopyBuffer;
  993.    RecordCount      : Integer;
  994.  
  995. BEGIN
  996.    KTrim(Input_File);
  997.    KTrim(OutPut_File);
  998.    IF Input_File=OutPut_File THEN  {jestlize jmena jsou stejna, }
  999.       BEGIN                        {nastanou problemy}
  1000.          Return_Code := 5;         {pristup neumoznen - soubor jiz existuje}
  1001.          ErrorCode := Return_Code;
  1002.          EXIT;                     {odchod}
  1003.       END;
  1004.    DOS_Return_Code := False;
  1005.    Assign(FileIn,Input_File);      {prirazeni vstupniho souboru}
  1006.    Assign(FileOut,Output_File);    {prirazeni vystupniho souboru}
  1007.    {$I-}
  1008.    Reset(FileIn);   {existuje opravdu takovy soubor?}
  1009.    {$I+}
  1010.    Return_Code := IOresult;
  1011.    IF (Return_Code = 0) THEN  {ano, muzeme provest}
  1012.     BEGIN
  1013.        IF EraseInputFile THEN             { jestlize chceme vymazat vstupni soubor }
  1014.           BEGIN
  1015.              Input_File:=Input_File+Chr(0);  { pak zkusime jako prvni funkci DOS  }
  1016.              OutPut_File:=OutPut_File+Chr(0);{ rename. To provede zmenu souboru   }
  1017.              Regs.Ah:=$56;                   { a nezabere zbytecne cas samotnym   }
  1018.              Regs.DS:=seg(Input_File);       { kopirovanim                        }
  1019.              Regs.Dx:=ofs(Input_File[1]);
  1020.              Regs.ES:=seg(OutPut_File);
  1021.              Regs.DI:=ofs(OutPut_File[1]);
  1022.              MsDos(Regs);
  1023.              IF Regs.AX = 0 THEN DOS_Return_Code := True
  1024.                             ELSE DOS_Return_Code := False;{neni stejny drive}
  1025.          END;
  1026.  
  1027.        IF NOT DOS_Return_Code THEN {DOSem to nelze, takze chceme provest}
  1028.        BEGIN                       {kopirovani}
  1029.           ReWrite(FileOut);   {vytvor vystupni soubor}
  1030.           New(CopyBufrPtr);   {inicializace bufferu pro kopirovani}
  1031.           REPEAT
  1032.              Blockread(FileIn,CopyBufrPtr^,RecordNum,RecordCount);
  1033.              {read data in}
  1034.              Blockwrite(FileOut,CopyBufrPtr^,RecordCount);
  1035.              {write data out}
  1036.           UNTIL RecordCount = 0;
  1037.           Dispose(CopyBufrPtr);  {uvolni pamet bufferu pro DOS}
  1038.           Close(FileIn);
  1039.           Close(FileOut);
  1040.           IF EraseInputFile THEN {$I-}Erase(filein){$I+};
  1041.           ErrorCode := IOresult;
  1042.           Return_Code := ErrorCode;
  1043.        END;
  1044.     END;
  1045. END;
  1046.  
  1047.  
  1048. (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  1049. FUNCTION IntToHex;
  1050. CONST
  1051.      HexChars: ARRAY[0..15] of char ='0123456789ABCDEF';
  1052. VAR
  1053.    Temp:Byte;
  1054.    TempStr:String[2];
  1055. BEGIN
  1056.    Temp:=Hi(IntNum); {konvertuj vyssi byte na hexadec.hodnotu}
  1057.    TempStr:=HexChars[Temp shr 4]+HexChars[Temp and $0F];
  1058.    Temp:=lo(IntNum); {konvertuj nizsi byte na haxadec.hodnotu}
  1059.    IntToHex:=TempStr+HexChars[Temp shr 4]+HexChars[Temp and $0F];
  1060. END;
  1061.  
  1062.  
  1063. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  1064. FUNCTION PIKDIR(Path:String;IncludeDir:Boolean):String;
  1065.  
  1066. PROCEDURE Hilite(X:Integer);
  1067. VAR
  1068.    Xcord,Row:Integer;
  1069. BEGIN
  1070.    Xcord:=(Trunc((X-1)/17)*15)+5;    {nastav pozici sloupce pro zvyrazneni}
  1071.    Row:=(X-(17*Trunc((X-1)/17)))+4;  {nastav pozici radku pro zvyrazneni}
  1072.    KAttr(Row,Xcord,1,12,79);         {zvyrazneni pozice}
  1073. END;
  1074.  
  1075. PROCEDURE LoLite(X:Integer);
  1076. VAR
  1077.    Xcord,Row:Integer;
  1078. BEGIN
  1079.    Xcord:=(Trunc((X-1)/17)*15)+5;    {nastav pozici sloupce pro "znevyrazneni"}
  1080.    Row:=(X-(17*Trunc((X-1)/17)))+4;  {nastav pozici radku pro "znevyrazneni"}
  1081.    KAttr(Row,Xcord,1,12,14);
  1082. END;
  1083.  
  1084. VAR
  1085.    One:AllFiles;
  1086.    X,Y,N:Integer;
  1087.    TempCounter,Start,Counter,Counter2,Total:Integer;
  1088.    More,Temp:String;
  1089.    MoreD,Done:Boolean;
  1090.    Position,OldPosition,Old2Position,Old3Position,
  1091.    Old4Position,Old5Position,ULRBox,ULCBox,LRRBox,LRCBox:Integer;
  1092.    C:Char;
  1093.    Near,Far:Byte;
  1094.    SavedTxtAttr:Byte;
  1095.    MainScr,BoxScr: SaveScrType;
  1096.  
  1097.  
  1098. PROCEDURE MakeBox;
  1099. VAR
  1100.    X,Y,N:Integer;
  1101. BEGIN
  1102.    SavedTxtAttr := TextAttr;                  {je nutno zachovat puvodni }
  1103.    TextAttr := 14;                            {TextAttr}
  1104.    IF Counter>17 THEN Y:=Trunc(Counter/17)+1
  1105.                  ELSE Y:=1;
  1106.    Start:=10;
  1107.    N:=Y;
  1108.    IF Y>5 THEN Y:=5;
  1109.    IF Counter>17 THEN Far:=22
  1110.                  ELSE Far:=Counter+5;
  1111.    Near:=(Y*15)+3;
  1112.    ULRBox := 4;
  1113.    ULCBox := 3;
  1114.    LRRBox := Far-3;
  1115.    LRCBox := Near-2;
  1116.    KSaveScr(ULRBox,ULCBox,LRRBox,LRCBox,BoxScr);
  1117.    KBox(ULRBox,ULCBox,LRRBox,LRCBox,29,14,Border2,True);
  1118.    Y:=N;
  1119.    CursorOff;
  1120.    FOR N:=1 TO Y DO
  1121.     FOR X:=1 TO 17 DO
  1122.     BEGIN
  1123.        Total:=Total+1;
  1124.        GotoXy(5+((N-1)*15),X+4);
  1125.        IF (Total<=Counter) AND (Total<86) THEN Write(One[Total]);
  1126.        IF (MoreD) AND ((Counter+85)>=Total) THEN Write(One[Total]);
  1127.     END;
  1128.    Done:=False;
  1129.    TextAttr := SavedTxtAttr;
  1130.    Hilite(Position);
  1131. END;
  1132.  
  1133.  
  1134. BEGIN
  1135.    DirFill(Path,One,Counter,IncludeDIR);
  1136.    {fill array ONE with listings in PATH}
  1137.    SortDir(One,Counter);      {trideni pole}
  1138.    Total:=0;
  1139.    MoreD:=False;
  1140.    NEW(MainScr);
  1141.    KSaveScr(1,1,25,80,MainScr);
  1142.    Position:=1;
  1143.    OldPosition:=1;
  1144.    NEW(BoxScr);
  1145.    MakeBox;
  1146.    REPEAT
  1147.       IF KeyPressed THEN
  1148.        BEGIN
  1149.           C:=ReadKey;
  1150.           IF C=#13 THEN
  1151.            BEGIN
  1152.               IF MoreD THEN Position:=Position+85;
  1153.               IF One[Position][1]<>'<' THEN
  1154.                BEGIN
  1155.                   Temp:='';
  1156.                   FOR X:=1 TO Length(Path)-3 DO
  1157.                       Temp:=Temp+Path[X];
  1158.                   Path:=Temp+One[Position];
  1159.                   PikDir := Path;
  1160.                   DONE := True;
  1161.                END
  1162.                                        ELSE
  1163.                BEGIN
  1164.                   Temp:='';
  1165.                   FOR X:=1 TO Length(Path)-4 DO
  1166.                       Temp:=Temp+Path[X];
  1167.                   Path:=Temp;
  1168.                   Temp:='';
  1169.                   FOR X:=1 TO Length(One[Position]) DO
  1170.                       IF (One[Position][X]<>'<') AND (One[Position][X]<>'>') THEN Temp:=Temp+One[Position][X];
  1171.                   IF Temp<>'..' THEN
  1172.                      BEGIN
  1173.                         Path:=Path+'\'+Temp+'\*.*';
  1174.                         Old5Position:=Old4Position;
  1175.                         Old4Position:=Old3Position;
  1176.                         Old3Position:=Old2Position;
  1177.                         Old2Position:=OldPosition;
  1178.                         OldPosition:=Position;
  1179.                         Position:=1;
  1180.                      END
  1181.                                 ELSE
  1182.                      BEGIN
  1183.                         X:=Length(Path)+1;
  1184.                         REPEAT
  1185.                            X:=X-1;
  1186.                         UNTIL Path[X]='\';
  1187.                         Path:=Copy(Path,1,X);
  1188.                         Path:=Path+'*.*';
  1189.                         Position:=OldPosition;
  1190.                         OldPosition:=Old2Position;
  1191.                         Old2Position:=Old3Position;
  1192.                         Old3Position:=Old4Position;
  1193.                         Old4Position:=Old5Position;
  1194.                      END;
  1195.                   KRestoreScr(BoxScr);
  1196.                   DirFill(Path,One,Counter,IncludeDIR);
  1197.                   SortDir(One,Counter);
  1198.                   Total:=0;
  1199.                   MoreD:=False;
  1200.                   MakeBox;
  1201.                END;
  1202.            END;
  1203.           IF C=#0 THEN
  1204.            BEGIN
  1205.               Lolite(Position);
  1206.               C:=ReadKey;
  1207.               IF C=#68 THEN Done:=True;
  1208.               IF C=#80 THEN Position:=Position+1;
  1209.               IF C=#72 THEN Position:=Position-1;
  1210.               IF C=#75 THEN Position:=Position-17;
  1211.               IF C=#77 THEN Position:=Position+17;
  1212.               IF C=#73 THEN
  1213.                BEGIN
  1214.                   IF MoreD THEN
  1215.                    BEGIN
  1216.                       Counter:=TempCounter;
  1217.                       Total:=0;
  1218.                       KRestoreScr(BoxScr);
  1219.                       MoreD:=False;
  1220.                       Position:=1;
  1221.                       MakeBox;
  1222.                    END;
  1223.                END;
  1224.               IF C=#81 THEN
  1225.                BEGIN
  1226.                   IF Counter>85 THEN
  1227.                    BEGIN
  1228.                       TempCounter:=Counter;
  1229.                       Counter:=Counter-85;
  1230.                       KRestoreScr(BoxScr);
  1231.                       Total:=85;
  1232.                       MoreD:=True;
  1233.                       Position:=1;
  1234.                       MakeBox;
  1235.                    END;
  1236.                END;
  1237.               IF Position<1 THEN Position:=1;
  1238.               IF Position>Counter THEN Position:=Counter;
  1239.               IF Position>85 THEN Position:=85;
  1240.               HiLite(Position);
  1241.            END;
  1242.  
  1243.        END;
  1244.    UNTIL Done;
  1245.    KRestoreScr(MainScr); {obnov hlavni obrazovku}
  1246.    DISPOSE(BoxScr);      {uvolni pamet pro DOS}
  1247.    DISPOSE(MainScr);
  1248. END;
  1249.  
  1250. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  1251. (*
  1252.    Tato cast programu inicializuje promenne ActiveDp a LineWidth pri
  1253.    prvnim behu programu. Promenna VideoMode muze byt pouzita spolu s
  1254.    ActiveDP a LineWidth.
  1255. *)
  1256.  
  1257. BEGIN
  1258.    DirectVideo := TRUE;
  1259.    VideoMode := CurrentVideoMode;
  1260. END.
  1261.  
  1262. (******************************************************************************
  1263.