home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / KTOOLS31.ZIP / KTOOLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-01-19  |  51.1 KB  |  1,351 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;     (* Active Display Page               *)
  29.     LineWidth : Integer;  (* Line Width of current video mode  *)
  30.     VideoMode : Byte;     (* Current Video Mode i.e. 0,1,2,3,7 *)
  31.     ErrorCode : Integer;  (* Global integer for error traps    *)
  32.  
  33. FUNCTION CurrentVideoMode : Byte;
  34. (*
  35. This function returns the current video mode... 0..3 = color, 7 = mono.
  36. Global variables  LineWidth & ActiveDP are set each time this function
  37. is called.
  38. *)
  39.  
  40. PROCEDURE CursorOn;
  41. (*
  42. This procedure checks the current video mode and restores a normal cursor.
  43. *)
  44.  
  45. PROCEDURE CursorOff;
  46. (*
  47. This procedure sets bit five of the cursor control byte, turning the cursor
  48. off.
  49. *)
  50.  
  51. FUNCTION KUCase(S:String):String;
  52. (*
  53. This function uses upcase procedure to convert an entire string or line from
  54. a text file to all uppercase characters.
  55. *)
  56.  
  57. FUNCTION KLCase(S:String):String;
  58. (*
  59. This function uses CHR & ORD and does just the oppsite of KUCase.
  60. *)
  61.  
  62. FUNCTION Color(FG,BG:Colors):Byte;
  63. (*
  64. This function returns the color attribute result for the combo FG on BG.
  65. The blinking bit is removed.
  66. *)
  67.  
  68. PROCEDURE KAttr(Row,Col,Rows,Cols:Integer;Attr:Byte);
  69. (*
  70. This procedure puts the specified Attribute beginning at Row/Col and goes
  71. Cols by Rows.
  72. *)
  73.  
  74. PROCEDURE KFill(Row,Col,Rows,Cols:Integer;Ch:Char;Attr:Byte);
  75. (*
  76. This procedure puts the specified Character beginning at Row/Col and goes
  77. Cols by Rows.
  78. *)
  79.  
  80. PROCEDURE KTrim(VAR S:String);
  81. (*
  82. This procedure trims all leading and trailing blanks from a string.
  83. *)
  84.  
  85. PROCEDURE KWrite(Row,Col:Integer;Attr:Byte;S:String);
  86. (*
  87. This procedure writes at string beginning at Row/Col with text Attr.
  88. It looks for the actual param on the stack.
  89. *)
  90.  
  91. PROCEDURE KWriteV(Row,Col:Integer;Attr:Byte;VAR S:String);
  92. (*
  93. This procedure writes at string beginning at Row/Col with text Attr.
  94. It looks for the param address on the stack.
  95. *)
  96.  
  97. PROCEDURE KWriteC(Row:Integer;Attr:Byte;S:String);
  98. (*
  99. This procedure writes at string beginning at Row/Col with text Attr.
  100. The output is centered on the screen between column 1 & 80.
  101. *)
  102.  
  103. PROCEDURE KWriteCV(Row:Integer;Attr:Byte;VAR S:String);
  104. (*
  105. This procedure writes at string beginning at Row/Col with text Attr.
  106. The output is centered on the screen between column 1 & 80.
  107. It looks for the param address on the stack.
  108. *)
  109.  
  110.  
  111. FUNCTION ReadPen:Integer;
  112. (*
  113. This function reads the current position of the light pen after it has been
  114. triggered and returns the value in ReadPen as an integer
  115. *)
  116.  
  117. FUNCTION PenPosition(Row,Col:Byte):Integer;
  118. (*
  119. This function returns an integer value of Row/Col which corresponds to the
  120. integer value that is returned when a call to ReadPen is made.
  121. *)
  122.  
  123. FUNCTION PenRow(Pen_Position:Integer):Byte;
  124. (*
  125. This function returns the row pointed to by the integer value Pen_Position.
  126. *)
  127.  
  128. FUNCTION PenCol(Pen_Position:Integer):Byte;
  129. (*
  130. This function returns the col pointed to by the integer value Pen_Position.
  131. *)
  132.  
  133. (*
  134.    NOTE: Uses for the light pen routines;
  135.  
  136.    ReadPen :
  137.              Will return the position selected by the light pen if it has been
  138.              triggered. Otherwise ReadPen returns 0. The integer value contains
  139.              the row position in the Hi byte and the column in the Lo byte.
  140.  
  141.    PenPosition :
  142.              This routine is useful for calculating the integer value for
  143.              a particular screen row and col.  The integer value can be
  144.              matched aganist the value returned by ReadPen to determine
  145.              a programs action.
  146.  
  147.    PenRow  : This returns the row position and is good for program action based
  148.              on input of a particular screen row instead of an X/Y location.
  149.  
  150.    PenCol  : This returns the col position and is good for program action based
  151.              on input of a particular screen column instead of a X/Y location.
  152.  
  153. *)
  154.  
  155.  
  156. PROCEDURE KSaveScr(ULRow,ULCol,Rows,Cols : Byte;
  157.                    VAR Dest_Variable : SaveScrType);
  158. (*
  159. This procedure will start at ULRow/ULCol and store the screen area between
  160. Rows/Cols to the variable Dest_Variable. The first four bytes of Dest_Variable
  161. contain 1)ULRow 2)ULCol 3)Rows 4)Cols  thus the screen is restored simply by
  162. calling KRestoreScr(Source_Variable);
  163. *)
  164.  
  165. PROCEDURE KRestoreScr(Source_Variable : SaveScrType);
  166. (*
  167. This procedure restores to the screen, the contents of Source_Variable. The
  168. first four bytes point to the area of the screen where Source_Variable is to be
  169. put.  I decided on this way since with other types of screen saving routines
  170. I was continually having to go back and see what coordinates I used for a given
  171. screen save.
  172. -------------------------------------------------------------------------------
  173.    NOTE  KSaveScr & KRestoreScr are not as fast as similar inline routines and
  174.    are not meant to be. Rather they display the ability of using easy to use
  175.    BIOS routines interfaced with TP4's built in speed to accomplish the task.
  176. *)
  177.  
  178.  
  179. PROCEDURE KBox (ULRow,ULCol,Rows,Cols: Integer;
  180.                 FrameAttr,WindowAttr : Byte;
  181.                 Border               : BorderType;
  182.                 ClearWindow          : Boolean);
  183. (*
  184. This procedure draws a box using 1 of 5 frame types.  The fore/background colors
  185. of the frame must be given as well as a color for the actual window.  ClearWindow
  186. is a flag to clear the window area using WindowAttr with blanks/spaces or leave
  187. the contents inside the window intact. If the window is not cleared then the
  188. text attribute of the window is unchanged.
  189. *)
  190.  
  191. FUNCTION KVertMenu(Selection_Start : INTEGER; {starting menu selection hilited}
  192.                    VAR MenuList;               {list of menu items             }
  193.                    MenuItemTotal,              {total number of menu items     }
  194.                    XStart,                     {starting column position       }
  195.                    YStart,                     {starting row postition         }
  196.                    XHiliteStart,               {hilite starting column number  }
  197.                    LengthOfHilite,             {number of columns to hilite    }
  198.                    NormalAttr,                 {normal text attribute for menu }
  199.                    HiliteAttr :                {attribute of hilited item      }
  200.                    INTEGER):INTEGER;           {function returns integer value }
  201. (*
  202. This procedure takes a array of items of menuitemtype and produces a vertical
  203. menu of those items. On return KVertMenu holds the choice number as integer
  204. type. - MenuList - is a untyped variable, assigned to in the procedure by turbo's
  205. absolute statement. If menuitemtotal is greater than your actual number of
  206. menu items then the extra will show up as garbage plucked from ram most likely.
  207. Since Menu is declared as VAR we deal directly with the data in memory and not
  208. a mirror image, however no alteration of the data takes place and any extra
  209. memory locations read should be left unaltered.  None the less, we all know
  210. that PC-Spooks abound in the strangest places.
  211. *)
  212.  
  213. FUNCTION KHorizMenu(Selection_Start:INTEGER; {starting menu selection hilited}
  214.                     VAR MenuList,            {list of menu items             }
  215.                         MenuDesc;            {description of each item       }
  216.                     MenuItemTotal,           {total number of menu items     }
  217.                     MenuWindowWidth,         {number of columns for menu     }
  218.                     XStart,                  {starting column position       }
  219.                     YStart,                  {starting row postition         }
  220.                     NormalAttr,              {normal text attribute for menu }
  221.                     HiliteAttr,              {attribute of hilited item      }
  222.                     DescAttr:                {color for descriptions         }
  223.                     INTEGER):INTEGER;        {function returns integer value }
  224.  
  225. (*
  226. This procedure takes a array of items of menuitemtype and produces a horizontal
  227. menu of those items, accompanied by an optional description of each item.
  228. On return KHorizMenu holds the choice number as integer type.  MenuList - is an
  229. untyped variable, assigned to in the procedure by turbo's absolute statement.
  230. If menuitemtotal is greater than your actual number of menu items then the
  231. extra will show up as garbage plucked from ram most likely. Since Menu is
  232. declared as VAR we deal directly with the data in memory and not a mirror image
  233. However no alteration of the data takes place and any extra memory locations
  234. read should be left unaltered.  None the less, we all know that PC-Spooks
  235. abound in the strangest places.
  236. *)
  237.  
  238. PROCEDURE  CopyFile(Input_File,           {filename.ext of file to copy}
  239.                     Output_File           {filename.ext of created file}
  240.                                :String;
  241.                     VAR Return_Code       {DOS error return code}
  242.                                :Integer;
  243.                     EraseInputFile:Boolean);
  244. (*
  245. This procedure will copy Input_File to the file name created as OutPut_File.
  246. This is an actual carbon copy, therefore the filenames cannot be the same.
  247. Rename a file is supported through DOS. Rename a file automatically removes
  248. the old file. Therefore if "EraseInputFile" is true we will try and use the
  249. DOS function to copy the file to its new name. If renaming causes an
  250. error then the drives are most likely not the same and the procedure resorts
  251. to the copying routine. If "EraseInputFile" is false then the DOS function
  252. is bypassed and we simply make a carbon copy of the file.
  253. *)
  254.  
  255.  
  256. FUNCTION IntToHex(IntNum:Integer):String;
  257. (*
  258. This function takes and integer value as it's arg. and returns a Hexadecimal
  259. ASCII representation of type string.
  260. *)
  261.  
  262.  
  263. FUNCTION Space(Number:Integer):String;
  264. (*
  265. This function will return  {Number} of spaces long of type string in SPACE.
  266. *)
  267.  
  268.  
  269. PROCEDURE DirFill(VAR Path:String;      {declared search path}
  270.                   VAR Files:AllFiles;   {array of all files in the directory}
  271.                   VAR Counter:Integer; {total number of files in the dir }
  272.                   IncludeDirListings:Boolean);
  273. (*
  274. Given the search path in PATH, an array of type ALLFILES is built into variable
  275. FILES. COUNTER holds the number of valid entries and thus the total number of
  276. files contained in FILES. If INCLUDEDIRLISTINGS is true then all directories
  277. within the passed dir path will be included in the array and may be selected
  278. *)
  279.  
  280. PROCEDURE SortDir(VAR Files:AllFiles;   {array of all files in the directory}
  281.                   VAR Counter:Integer); {number of files you want sorted in}
  282.                                         {FILES up to the total number of files}
  283. (*
  284. This procedure will sort on name, the number of files you specify in counter.
  285. You can sort as many or few as you like remembering that those you don't sort
  286. will be in the same order as when the procedure was called. i.e. every file
  287. above COUNTER.  Note also that since ALLFILES is an array up to 500, if you
  288. specify more files be sorted than you actually have, your gonna wind up with
  289. junk in the (COUNTER-Actual) number of first array positions. Or
  290. somewhereabouts as PC-Spooks go.
  291. *)
  292.  
  293.  
  294. FUNCTION PIKDIR(Path:String;IncludeDir:Boolean):String;
  295. (*
  296. The function returns the path/file in PIKDIR.  The dirpath should be specified
  297. in PATH.  If INCLUDEDIR is true then you will be able to move thru all avail-
  298. able directories to choose a file from. If INCLUDEDIR is false then only the
  299. files found in PATH will be available for selection.
  300.  
  301. NOTE:PIKDIR will return the complete path+File. It will not return PATH without
  302. a file.  This could be modified without hassel.
  303. *)
  304.  
  305.  
  306. IMPLEMENTATION
  307. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  308.  
  309. FUNCTION CurrentVideoMode:Byte;
  310. VAR
  311.     Regs:Registers;               {Registers defined in DOS unit}
  312. BEGIN
  313.     Regs.AH := $F;
  314.     Intr($10,Regs);
  315.     CurrentVideoMode:=Regs.AL;    {Assign video mode to function name}
  316.     ActiveDP:=Regs.BH;            {Active page returned in register BH}
  317.     LineWidth:=Regs.AH;           {Characters per line returned in AH}
  318. END;
  319. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  320.  
  321. PROCEDURE CursorOn;
  322. VAR
  323.     Regs:Registers;               {Registers defined in DOS unit}
  324.     Mode:Byte;
  325. BEGIN
  326.     Mode := CurrentVideoMode;     {get current video mode}
  327.     IF Mode IN[0..3] THEN
  328.        BEGIN
  329.           Regs.AH := $01;                { Restore Color Cursor }
  330.           Regs.CH := $06;
  331.           Regs.CL := $07;
  332.           Intr($10,Regs);
  333.        END
  334.     ELSE
  335.        IF Mode = 7 THEN
  336.           BEGIN
  337.              Regs.AH := $01;            { Restore Mono Cursor }
  338.              Regs.CH := $C;
  339.              Regs.CL := $D;
  340.              Intr($10,Regs);
  341.           END
  342.        ELSE
  343.           BEGIN
  344.              Regs.AH := $01;            { We're gonna put a cursor }
  345.              Regs.CH := $1;             { on the screen no matter what }
  346.              Regs.CL := $D;             { one big block  if all else fails }
  347.              Intr($10,Regs);
  348.           END;
  349.  
  350. END;
  351. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  352.  
  353. PROCEDURE CursorOff;
  354. VAR
  355.    Regs:Registers;
  356. BEGIN                            { Set bit 5 of cursor control byte }
  357.    Regs.AH := $01;               { which turns cursor off           }
  358.    Regs.CH := $20;
  359.    Intr($10,Regs);
  360. END;
  361. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  362.  
  363. FUNCTION KUCase(S:String):String;
  364. VAR
  365.    I: integer;
  366. BEGIN
  367.    FOR I := 1 TO Length(S) DO S[I] := UpCase(S[I]);
  368.    KUCase := S;
  369. END;
  370. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  371.  
  372. FUNCTION KLCase(S:String):String;
  373. VAR
  374.    I: integer;
  375. BEGIN
  376.    FOR I := 1 TO Length(S) DO
  377.       IF S[I] IN['A'..'Z'] THEN   {If character is A-Z }
  378.          S[I]:=CHR(ORD(S[I])+$20);{Add HEX 20 ordinal value for lowercase}
  379.    KLCase := S;
  380. END;
  381. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  382.  
  383. FUNCTION Color(FG,BG:Colors):Byte;
  384. BEGIN
  385.    Color := (FG+(BG SHL 4)) MOD 128;{shift BG 4 places left(nibble) and add FG}
  386. END;                                {MOD 128 removes the blink}
  387. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  388.  
  389. PROCEDURE KAttr(Row,Col,Rows,Cols:Integer;Attr:Byte);
  390. VAR
  391.     Ch,X,Y,R,C:Integer;
  392.     Regs:Registers;
  393. BEGIN
  394.    R:=(Row+(Rows-1));
  395.    C:=(Col+(Cols-1));
  396.    REPEAT
  397.       X:=Col;
  398.          REPEAT
  399.                GOTOxy(x,Row);              {BIOS call to read screen character}
  400.                Regs.AH:=$08;               {and attribute                     }
  401.                Regs.BH:=ActiveDP;          {Specify active page}
  402.                Intr($10,Regs);
  403.  
  404.                { Regs.AL contains the character read with service 8.}
  405.  
  406.                Regs.AH:=$09;             {BIOS call to write Character and}
  407.                                          {attribute to screen}
  408.                Regs.BH:=ActiveDP;        {Specify active page}
  409.                Regs.BL:=Attr;            {Specify attribute }
  410.                Regs.CX:=$01;             {write it once }
  411.                Intr($10,Regs);
  412.                X:=X+1;                   {INC X i.e col position}
  413.          UNTIL X>C;
  414.       Row:=Row+1;                        {INC Row i.e. Row position}
  415.    UNTIL Row > R;
  416. END;
  417. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  418.  
  419. PROCEDURE KFill(Row,Col,Rows,Cols:Integer;Ch:Char;Attr:Byte);
  420. VAR
  421.     R:Integer;
  422.     Regs:Registers;
  423.  
  424. (**)
  425.  
  426. BEGIN
  427.    R:=(Row+(Rows-1));
  428.    REPEAT
  429.       GOTOxy(col,Row);
  430.       Regs.AH:=$09;
  431.       Regs.AL:=ORD(Ch);
  432.       Regs.BH:=ActiveDP;
  433.       Regs.BL:=Attr;
  434.       Regs.CX:=cols;
  435.       Intr($10,Regs);
  436.       Row:=Row+1;
  437.    UNTIL Row > R;
  438. END;
  439.  
  440. (*
  441.  
  442.  {If you don't want to use the Bios calls, comment them out and open this
  443.   section up and recompile. NOTE: BIOS is slower than write if DirectVideo is
  444.   set to true, however by placing the number of cols to fill in the repeating
  445.   register CX the difference is only slightly noticable.}
  446.  
  447.     S : String;
  448.     SavedTextAttr:Integer;
  449.  
  450. BEGIN
  451.    S:='';
  452.    FOR X := 1 to Cols DO
  453.       S:=S+Ch;
  454.    R:=(Row+(Rows-1));
  455.    SavedTextAttr:=CRT.TextAttr;
  456.    CRT.TextAttr:=Attr;
  457.    REPEAT
  458.          GOTOxy(Col,Row);
  459.          Write(s);
  460.          Row:=Row+1;
  461.    UNTIL Row > R;
  462.    CRT.TextAttr:=SavedTextAttr
  463. END;
  464. *)
  465.  
  466. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  467.  
  468. PROCEDURE KTrim(VAR s : string);
  469. VAR
  470.     x,b,e : Integer;
  471. BEGIN
  472.     For X := 1 to LENGTH(s) DO
  473.        IF s[1]=' ' THEN DELETE(S,1,1); {delete leading spaces}
  474.  
  475.     {This may look wrong to check the entire string, but we look at }
  476.     {S[ 1 ] each time and delete blanks at same until a character appears]
  477.     {From that point on S[1] stays the first character we skipped;}
  478.     {This would work as well
  479.                               REPEAT
  480.                                  IF s[1] = ' ' THEN DELETE(S,1,1);
  481.                               UNTIL s[1] <> ' ';
  482.  
  483.      and on lengthy strings would be faster.  }
  484.  
  485.     b:=1;
  486.     e:=ORD(s[0]);
  487.     REPEAT
  488.        IF s[e] = ' ' THEN DELETE(S,e,1);
  489.        DEC(e);
  490.     UNTIL s[e] <> ' ';
  491.  
  492. END;
  493. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  494.  
  495. (*
  496.    The following procedures are straight forward enough and no BIOS is used
  497.    in the code.   TEXTATTR is assigned in the CRT unit and referrenced as
  498.    CRT.TextAttr.  This holds the attribute of the current video page and not
  499.    necessarily a certain character pos. Thus we save it and change it before
  500.    we write to the screen with our string.  Then we put it back the way we
  501.    found it. Centering Text is simply taking the LineWidth minus the length
  502.    of the string divided by 2, which gives us the starting column for our
  503.    gotoxy(?,Row) statement.
  504. *)
  505.  
  506. PROCEDURE KWrite(Row,Col:Integer;Attr:Byte;S:String);
  507. VAR                             {S is actual 'Hello World' or variable }
  508.     SavedTextAttr:Integer;      {VarParm := 'Hello World' }
  509. BEGIN
  510.     SavedTextAttr:=CRT.TextAttr;
  511.     CRT.TextAttr:=Attr;
  512.     GotoXY(Col,Row);
  513.     Write(s);
  514.     CRT.TextAttr:=SavedTextAttr
  515. END;
  516. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  517.  
  518. PROCEDURE KWriteV(Row,Col:Integer;Attr:Byte;VAR S:String);
  519. VAR                           {S must be a variable, only the address is passed}
  520.     SavedTextAttr:Integer;    {to save space on the stack}
  521. BEGIN
  522.     SavedTextAttr:=CRT.TextAttr;    {Save current page text attribute}
  523.     CRT.TextAttr:=Attr;             {Assign our attribute value}
  524.     GotoXY(Col,Row);                {Move cursor to our strating Pos.}
  525.     Write(s);                       {Write our string and attribute}
  526.     CRT.TextAttr:=SavedTextAttr;     {Restore original text attribute}
  527.  
  528.     {We want to restore the original so that TURBO's write & writeln will
  529.      function with a specified global attribute in CRT.TextAttr and we can
  530.      still write our own with no interference}
  531. END;
  532. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  533.  
  534. PROCEDURE KWriteC(Row:Integer;Attr:Byte;S:String);
  535. VAR
  536.     X,SavedTextAttr:Integer;
  537. BEGIN
  538.     SavedTextAttr:=CRT.TextAttr;
  539.     CRT.TextAttr:=Attr;
  540.     X:=(LineWidth-Length(S)) DIV 2; {get cursor pos to write string centered}
  541.     GotoXY(X,Row);
  542.     Write(s);
  543.     CRT.TextAttr:=SavedTextAttr
  544. END;
  545. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  546.  
  547. PROCEDURE KWriteCV(Row:Integer;Attr:Byte;VAR S:String);
  548. VAR
  549.     X,SavedTextAttr:Integer;
  550. BEGIN
  551.     SavedTextAttr:=CRT.TextAttr;
  552.     CRT.TextAttr:=Attr;
  553.     X:=(LineWidth-Length(S)) DIV 2;
  554.     GotoXY(X,Row);
  555.     Write(s);
  556.     CRT.TextAttr:=SavedTextAttr
  557. END;
  558. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  559.  
  560. FUNCTION ReadPen:Integer;
  561. VAR Regs : Registers;
  562. BEGIN
  563.    Regs.AH := 4;
  564.    Intr($10,Regs);
  565.    IF Regs.AH = 1 THEN ReadPen := Regs.DX;
  566. END;
  567. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  568.  
  569. FUNCTION PenPosition(Row,Col:Byte):Integer;
  570. BEGIN
  571.    PenPosition := (Row SHL 8)+Col;
  572. END;
  573. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  574.  
  575. FUNCTION PenRow(Pen_Position:Integer):Byte;
  576. BEGIN
  577.    PenRow := Hi(Pen_Position);
  578. END;
  579. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  580.  
  581. FUNCTION PenCol(Pen_Position:Integer):Byte;
  582. BEGIN
  583.    PenCol := Lo(Pen_Position);
  584. END;
  585. (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  586.  
  587. PROCEDURE KSaveScr(ULRow,ULCol,Rows,Cols : Byte;
  588.                    VAR Dest_Variable : SaveScrType);
  589. VAR
  590.     Ch,X,Y,R,C,Counter:Integer;
  591.     Regs:Registers;
  592. BEGIN
  593.    R:=(ULRow+(Rows-1));
  594.    C:=(ULCol+(Cols-1));
  595.    Dest_Variable^[1]:=ULRow;     {Store the Ystart,Xstart, number of rows}
  596.    Dest_Variable^[2]:=ULCol;     {and number of columns in the first 4 pos}
  597.    Dest_Variable^[3]:=Rows;      {of the variable}
  598.    Dest_Variable^[4]:=Cols;
  599.    Counter := 5; {Set counter to first byte of the actual screen information}
  600.    REPEAT
  601.       X:=ULCol;
  602.          REPEAT
  603.                GOTOxy(x,ULRow);
  604.                Regs.AH:=$08;     {BIOS function number}
  605.                Regs.BH:=ActiveDP;{active display page}
  606.                Intr($10,Regs);   {call the interrupt}
  607.                Dest_Variable^[Counter]:=Regs.AL; {Character Read}
  608.                INC(Counter);
  609.                Dest_Variable^[Counter]:=Regs.AH; {Attribute Read}
  610.                INC(Counter);
  611.                INC(X);                   {INC X i.e col position}
  612.          UNTIL X>C;
  613.       INC(ULRow);                          {INC Row i.e. Row position}
  614.    UNTIL ULRow > R;
  615. END;
  616. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  617.  
  618. PROCEDURE KRestoreScr(Source_Variable : SaveScrType);
  619. VAR
  620.     Ch,X,Y,R,C,
  621.     Row,Col,Counter:Integer;
  622.     Regs:Registers;
  623. BEGIN
  624.    R:=(Source_Variable^[1]+(Source_Variable^[3]-1));
  625.    C:=(Source_Variable^[2]+(Source_Variable^[4]-1));
  626.    Row := Source_Variable^[1];
  627.    Col := Source_Variable^[2];
  628.    Counter := 5;
  629.    REPEAT
  630.       X:=Col;
  631.          REPEAT
  632.                GOTOxy(x,Row);              {BIOS call to read screen character}
  633.                Regs.AH:=$09;             {BIOS call to write Character and}
  634.                                          {attribute to screen}
  635.                Regs.AL:=Source_Variable^[Counter]; {Specify Character }
  636.                INC(Counter);
  637.                Regs.BL:=Source_Variable^[Counter]; {Specify Attribute }
  638.                INC(Counter);
  639.                Regs.BH:=ActiveDP;        {Specify active page}
  640.                Regs.CX:=$01;             {write it once }
  641.                Intr($10,Regs);
  642.                INC(X);                   {INC X i.e col position}
  643.          UNTIL X>C;
  644.       INC(Row);                        {INC Row i.e. Row position}
  645.    UNTIL Row > R;
  646. END;
  647. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  648.  
  649. PROCEDURE KBox (ULRow,ULCol,Rows,Cols: Integer;
  650.                 FrameAttr,WindowAttr : Byte;
  651.                 Border               : BorderType;
  652.                 ClearWindow          : Boolean);
  653. VAR
  654.    Y,Wh,Wl,H,L : Integer;
  655. BEGIN
  656.   IF (Rows>=2) AND (Cols>=2) THEN     {box can be no smaller than 2x2}
  657.   BEGIN                               {which ain't much of a box really}
  658.     L:=Lo(WindMin);H:=Hi(WindMin);
  659.     Wl:=Lo(WindMax);Wh:=Hi(WindMax);
  660.     WindMax:=(25 SHL 8)+Wl; {can go past last row by 1 row }
  661.     WITH Border DO   {save ourselves some typing via "WITH (record name) DO}
  662.     BEGIN
  663.       KWrite(ULRow,ULCol,FrameAttr,TL);           {top left corner}
  664.       KFill(ULRow,ULCol+1,1,Cols-2,FH,FrameAttr); {fill cols with horiz char}
  665.       KWrite(ULRow,ULCol+Cols-1,FrameAttr,TR);    {top right corner}
  666.       FOR Y := ULRow+1 TO ULRow+Rows-2 DO
  667.         BEGIN
  668.           KWrite(Y,ULCol,FrameAttr,FV);        {loop thru and put the vertical}
  669.           KWrite(Y,ULCol+Cols-1,FrameAttr,FV); {char on both sides}
  670.         END;
  671.       KWrite(ULRow+Rows-1,ULCol,FrameAttr,BL);           {bottom left corner}
  672.       KFill(ULRow+Rows-1,ULCol+1,1,Cols-2,FH,FrameAttr); {fill cols with horiz}
  673.       KWrite(ULRow+Rows-1,ULCol+Cols-1,FrameAttr,BR);    {Bottom right corner}
  674.  
  675.       IF ClearWindow THEN     {if true then clear out the window}
  676.       KFill (ULRow+1,ULCol+1,Rows-2,Cols-2,' ',WindowAttr);
  677.  
  678.       WindMax:=(Wh SHL 8)+Wl; {restore bottom corner of window }
  679.       Window(L,H,Wl,Wh);      {restore original window screen}
  680.       GOTOxy(1,1);            {don't leave the cursor hid on line 26}
  681.     END
  682.   END
  683. END;
  684.  
  685. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  686.  
  687. FUNCTION KVertMenu(Selection_Start : INTEGER; {starting menu selection hilited}
  688.                   VAR MenuList;               {list of menu items             }
  689.                   MenuItemTotal,              {total number of menu items     }
  690.                   XStart,                     {starting column position       }
  691.                   YStart,                     {starting row postition         }
  692.                   XHiliteStart,               {hilite starting column number  }
  693.                   LengthOfHilite,             {number of columns to hilite    }
  694.                   NormalAttr,                 {normal text attribute for menu }
  695.                   HiliteAttr :                {attribute of hilited item      }
  696.                   INTEGER):INTEGER;           {function returns integer value }
  697.  
  698.  
  699. VAR
  700.    Menu : Array[1..2] OF MenuItemType absolute MenuList;
  701.    SelectionMade : Boolean;    {understand the use of "absolute" before}
  702.    X,Y : INTEGER;              {you use it in earnest, and save yourself}
  703.    Row,Col,Rows,Cols,          {many headaches}
  704.    Choice : INTEGER;
  705.    Ch : Char;
  706.  
  707. BEGIN
  708.    Col := XHiliteStart;
  709.    Rows := 1;
  710.    Cols := LengthOfHilite;
  711.    Choice := Selection_Start;
  712.    FOR y := 0 to MenuItemTotal-1 DO   {put up the menu list}
  713.       KWrite(YStart+y,XStart,NormalAttr,Menu[y+1]);
  714.    Row := YStart+Selection_Start-1;  {Row Position to hilite first}
  715.    KAttr(Row,Col,Rows,Cols,HiliteAttr);
  716.    SelectionMade := False;   {haven't made a selection yet}
  717.  
  718.    REPEAT
  719.       Ch := ReadKey;
  720.       IF Ch = #13 THEN  { if ENTER then }
  721.          BEGIN
  722.             KVertMenu := Choice;  {assign KVertmenu your choice}
  723.             SelectionMade := True;   {selection has been made}
  724.          END
  725.       ELSE
  726.          IF Ch = #27 THEN  { if ESC then }
  727.             BEGIN
  728.                KVertMenu := 0; { assign KVertMenu 0 because we have no 0 item }
  729.                EXIT;           { test for 0 = (No OPeration) in your program  }
  730.             END                { it's a way out of indecision on the users part}
  731.          ELSE
  732.             IF Ch = #0 Then    { if ch = 0 then we have an extended key }
  733.                Ch := ReadKey;  { TP4 docs say we'll never have a ch=0 except }
  734.       CASE Ch OF               { for extended keys. no more null spooks }
  735.  
  736.          #72 : BEGIN  {UP arrow key}
  737.                   KAttr(Row,Col,Rows,Cols,NormalAttr);
  738.                   IF Choice = 1 THEN BEGIN
  739.                                         Choice := MenuItemTotal;
  740.                                         Row    := Ystart+MenuItemTotal-1;
  741.                                      END
  742.                   ELSE
  743.                                      BEGIN
  744.                                         Choice := Choice-1;
  745.                                         Row    := Row-1;
  746.                                      END;
  747.                   KAttr(Row,Col,Rows,Cols,HiliteAttr);
  748.                END;
  749.          #80 : BEGIN  {DOWN arrow}
  750.                   KAttr(Row,Col,Rows,Cols,NormalAttr);
  751.                   IF Choice = MenuItemTotal THEN BEGIN
  752.                                         Choice := 1;
  753.                                         Row    := Ystart;
  754.                                      END
  755.                   ELSE
  756.                                      BEGIN
  757.                                         Choice := Choice+1;
  758.                                         Row    := Row+1;
  759.                                      END;
  760.                   KAttr(Row,Col,Rows,Cols,HiliteAttr);
  761.                END;
  762.       END;
  763.    UNTIL SelectionMade;
  764. END;
  765. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  766.  
  767. FUNCTION KHorizMenu(Selection_Start:INTEGER; {starting menu selection hilited}
  768.                     VAR MenuList,            {list of menu items             }
  769.                         MenuDesc;            {description of each item       }
  770.                     MenuItemTotal,           {total number of menu items     }
  771.                     MenuWindowWidth,         {number of columns for menu     }
  772.                     XStart,                  {starting column position       }
  773.                     YStart,                  {starting row postition         }
  774.                     NormalAttr,              {normal text attribute for menu }
  775.                     HiliteAttr,              {attribute of hilited item      }
  776.                     DescAttr:                {color for descriptions         }
  777.                     INTEGER):INTEGER;        {function returns integer value }
  778.  
  779. VAR
  780.    Menu : Array[1..2] OF MenuItemType absolute MenuList;
  781.    Desc : Array[1..2] OF MenuDescType absolute MenuDesc;
  782.  
  783.    (*
  784.       MenuDescType is defined as String[80], hence your description can be 80
  785.       characters in length.  However, it is your responsibility to check that
  786.       your description fits inside your specified -MenuWindowWidth-. This is
  787.       obvious if you should box around your menu and the description is too
  788.       long.  MenuWindowWidth defines the confines of the MenuList and not the
  789.       description.
  790.    *)
  791.  
  792.    MPos : Array[1..25] OF Integer;            {screen pos for each item}
  793.    PageBreak : Array[1..10,0..1] OF Integer;  {start & end item number per page}
  794.  
  795.    SelectionMade : Boolean;
  796.    X,Y,Space,Page,
  797.    Row,Col,
  798.    Choice,TotalX,
  799.    Position,MaxPage : INTEGER;
  800.    Ch : Char;
  801.  
  802.  
  803. FUNCTION MenuItemLength(A:Integer):Integer; { length of a menu item }
  804. BEGIN
  805.   MenuItemLength := ORD(Menu[A][0]);
  806. END;
  807.  
  808. FUNCTION MenuDescLength(A:Integer):Integer; { Length of a description }
  809. BEGIN
  810.   MenuDescLength := ORD(Desc[A][0]);
  811. END;
  812.  
  813. BEGIN (* KHorizMenu *)
  814.    Row    := YStart;
  815.    Col    := XStart;
  816.    Space  := 3;      { distance between items }
  817.    Page   := 1;      { define 1st page and Max Page though we }
  818.    MaxPage := 1;     { may change them shortly }
  819.    TotalX := XStart; { TotalX is an accumulator }
  820.    Position := Selection_Start; { define item position to default }
  821.    SelectionMade := False;   { we haven't picked one yet }
  822.    PageBreak[MaxPage][0] := 1;  { start with item 1 page 1 }
  823.  
  824.    FOR X := 1 TO MenuItemTotal DO
  825.       BEGIN
  826.          IF ( (TotalX-XStart)+MenuItemLength(X) > MenuWindowWidth ) THEN
  827.             BEGIN                              { If we exceed our windowwidth }
  828.                PageBreak[MaxPage][1] := X-1; {set current page end }
  829.                INC(MaxPage);                 {increase page by 1 }
  830.                PageBreak[MaxPage][0] := X;   {Set new page begin }
  831.                TotalX := XStart;             {reset our accumulator }
  832.                MPos[X] := TotalX;            {assign screen position }
  833.             END
  834.          ELSE
  835.             MPos[X] := TotalX;    { otherwise assign current totalx to MPos[x]}
  836.  
  837.       IF X = MenuItemTotal THEN       { ensure last page break holds our }
  838.          PageBreak[MaxPage][1] := X;  { total number of menu items }
  839.  
  840.       IF X = Selection_Start THEN  { match up the correct page }
  841.          Page := MaxPage;          { to our selection default  }
  842.  
  843.       TotalX  := TotalX+Space+MenuItemLength(X);
  844.       END;
  845.       (*
  846.       MaxPage is used above as our paging referrence. After this loop is
  847.       completed, each page break is defined as well as the starting position
  848.       for each menu item. The variable PAGE is assigned the current MaxPage
  849.       when X and Selection_Start matchup which lets us display the page
  850.       containing our default selection first.
  851.       *)
  852.  
  853. WHILE NOT SelectionMade DO
  854. BEGIN
  855.  
  856.    KFIll(Row,XStart,1,MenuWindowWidth,' ',NormalAttr);{clear item portion of window}
  857.  
  858.    FOR X := PageBreak[Page][0] TO PageBreak[Page][1] DO {loop through page and}
  859.       BEGIN                                             {put up the items     }
  860.          KWrite(Row,MPos[x],NormalAttr,Menu[X]);
  861.       END;
  862.  
  863.    KAttr(Row,MPos[Position],1,MenuItemLength(Position),HiLiteAttr);{hilite position}
  864.    KWrite(Row+1,XStart,DescAttr,Desc[Position]); {write the items description}
  865.  
  866.    Choice := Position; {useless exchange but it looked nice and neat}
  867.       Ch := ReadKey;                 {wait for a keystroke}
  868.       IF Ch = #13 THEN               { if ENTER then }
  869.          BEGIN
  870.             KHorizMenu := Choice;    {assign KHorizMenu your choice}
  871.             SelectionMade := True;   {selection has been made}
  872.          END
  873.       ELSE
  874.          IF Ch = #27 THEN            { if ESC then }
  875.             BEGIN
  876.                KHorizMenu := 0; { assign KHorizMenu 0 because we have no 0 item }
  877.                EXIT; { test for (0 = No OPeration) in your program    }
  878.             END      { it's a way out of indecision on the users part }
  879.          ELSE
  880.             IF Ch = #0 Then    { if ch = 0 then we have an extended key }
  881.                Ch := ReadKey;  { TP4 docs say we'll never have a ch=0 except }
  882.                                { for extended keys. no more null spooks }
  883. (*
  884. The key handling routines are easily enough understood by the use of the names
  885. as variables.  More programmers should realize that fact.
  886. The first action taken in both routines is to clear the hilited item and then
  887. clear the items description from the screen.  Notice that we use the length of
  888. the description as our COLS referrence, thus we clear only what we put up in
  889. the current description. No mess no hastle.
  890. *)
  891.  
  892.             CASE Ch OF
  893.                #75 : BEGIN  {left arrow key}
  894.                         KAttr(Row,MPos[Position],1,MenuItemLength(Position),NormalAttr);
  895.                         KFIll(Row+1,XStart,1,MenuDescLength(Position),' ',DescAttr);
  896.  
  897.                         IF (Position = 1) AND (Page = 1) THEN
  898.                            BEGIN
  899.                               Position := MenuItemTotal;
  900.                               Page := MaxPage;
  901.                            END
  902.                         ELSE
  903.                            IF Position = PageBreak[Page][0] THEN
  904.                               BEGIN
  905.                                  DEC(Position);
  906.                                  DEC(Page);
  907.                               END
  908.                            ELSE
  909.                                DEC(Position);
  910.                      END;
  911.  
  912.                #77 : BEGIN  {right arrow key}
  913.                         KAttr(Row,MPos[Position],1,MenuItemLength(Position),NormalAttr);
  914.                         KFIll(Row+1,XStart,1,MenuDescLength(Position),' ',DescAttr);
  915.  
  916.                         IF Position = MenuItemTotal THEN
  917.                            BEGIN
  918.                               Position := 1;
  919.                               Page := 1;
  920.                            END
  921.                         ELSE
  922.                            IF Position = PageBreak[Page][1] THEN
  923.                               BEGIN
  924.                                  INC(Position);
  925.                                  INC(Page);
  926.                               END
  927.                            ELSE
  928.                               INC(Position);
  929.                      END;
  930.       END;
  931. END; {while do}
  932. END;
  933.  
  934. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  935. PROCEDURE SortDir(VAR Files:AllFiles;VAR Counter:Integer);
  936. VAR
  937.    Flag:Boolean;
  938.    X:Integer;
  939.    Temp:String[12];
  940.  
  941. BEGIN
  942.    Flag:=False;
  943.    REPEAT
  944.      Flag:=False;
  945.      FOR X:=2 TO Counter DO {we stay one ahead of ourselves so start on 2}
  946.       IF (Files[X][1]='<') AND (Files[X-1][1]<>'<') THEN
  947.               BEGIN                       {-----------------------------------}
  948.                  Flag:=True;              { First we sort out all DIRECTORY   }
  949. {swap things}    Temp:=Files[X-1];        { entries in the array. ( They will }
  950. {around here}    Files[X-1]:=Files[X];    { occupy the first positions in the }
  951.                  Files[X]:=Temp;          { array.) processing the file names }
  952.               END                         { as we go along. Examining the three}
  953.    UNTIL NOT Flag;                        { sets of IF routines will show that}
  954.    REPEAT                                 { we look for dir/dir, dir/file, &  }
  955.       Flag:=False;                        { then file/file.                   }
  956.       FOR X:=2 TO Counter DO              {-----------------------------------}
  957.           IF (Files[X][1]='<') AND (Files[X-1][1]='<') THEN
  958.              IF Files[X]<Files[X-1] THEN
  959.               BEGIN
  960.                  Flag:=True;
  961.  {ditto}         Temp:=Files[X-1];
  962.                  Files[X-1]:=Files[X];
  963.                  Files[X]:=Temp;
  964.               END
  965.                                     ELSE
  966.                                                         ELSE
  967.            IF (Files[X]<Files[X-1]) AND (Files[X-1][1]<>'<') THEN
  968.              BEGIN
  969.                  Flag:=True;
  970.                  Temp:=Files[X-1];
  971.  {ditto}         Files[X-1]:=Files[X];
  972.                  Files[X]:=Temp;
  973.               END;
  974.    UNTIL NOT Flag;
  975. END;
  976.  
  977.  
  978. (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  979. PROCEDURE DirFill(VAR Path:String;VAR Files:AllFiles;
  980.                   VAR Counter:Integer;IncludeDirListings:Boolean);
  981. VAR
  982.    Attri:Byte;
  983.    SRec:SearchRec;   { searchrec is defined in the DOS unit of TP4 }
  984.  
  985. BEGIN
  986.    Attri:=$3F;  { attribute of anyfile at all }
  987.    Counter:=0;  { set accumulator to 0 }
  988.    FindFirst(Path,Attri,SRec); { TP4 function of DOS function Find First File}
  989.    IF DosError=0 THEN          {no problems then go ahead}
  990.     REPEAT
  991.        IF SRec.Name<>'.' THEN  {ignore in first directory listing}
  992.         BEGIN
  993.  
  994.            IF IncludeDirListings THEN
  995.               BEGIN
  996.                  INC(Counter);       {valid file so increase accumualtor by 1}
  997.                  IF SRec.Attr=Directory THEN
  998.                     Files[Counter]:='<'+SRec.Name+'>' {notate a directory entry}
  999.                  ELSE
  1000.                     Files[Counter]:=SRec.Name;        {add it as a file entry}
  1001.               END;
  1002.  
  1003.            IF NOT IncludeDirListings THEN
  1004.               IF SRec.Attr<>Directory THEN
  1005.                  BEGIN
  1006.                     INC(Counter);       {valid file so increase accumualtor by 1}
  1007.                     Files[Counter]:=SRec.Name;        {add it as a file entry}
  1008.                  END;
  1009.  
  1010.         END;
  1011.        Attri:=$3F;     {reset searchrec attribute to anyfile}
  1012.        FindNext(SRec); {TP4 function of DOS function to Find Next File}
  1013.     UNTIL DosError<>0; {loop until we're out of files (i.e. DosError:=18)}
  1014. END;
  1015.  
  1016.  
  1017. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  1018. FUNCTION Space(Number:Integer):String;
  1019.  
  1020. VAR
  1021.    X:Integer;
  1022.    TempSpace:String;
  1023.  
  1024. BEGIN
  1025.      TempSpace:='';
  1026.      FOR X:=1 TO Number DO           {make up a string of spaces from}
  1027.           TempSpace:=TempSpace+' ';  {1 to Number long}
  1028.      Space:=TempSpace;
  1029. END;
  1030.  
  1031.  
  1032. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  1033. PROCEDURE CopyFile (Input_File,Output_File:String;
  1034.                     VAR Return_Code:integer;EraseInputFile:Boolean);
  1035. CONST
  1036.    RecordSize = 128;
  1037.    RecordNum  = 128;
  1038. TYPE
  1039.    CopyBuffer = array[1..RecordSize,1..RecordNum] of byte;
  1040.  
  1041. VAR
  1042.    DOS_Return_Code  : Boolean;
  1043.    Regs             : Registers;
  1044.    FileIn,FileOut   : File;        {untyped file variables}
  1045.    CopyBufrPtr      : ^CopyBuffer; {the use of a pointer here keeps our program}
  1046.    RecordCount      : Integer;     {from carrying around such a large buffer}
  1047.                                    {throughout it's duration}
  1048. BEGIN
  1049.    KTrim(Input_File);
  1050.    KTrim(OutPut_File);
  1051.    IF Input_File=OutPut_File THEN  {if the file names are exact then we're in}
  1052.       BEGIN                        {trouble}
  1053.          Return_Code := 5;         {access denied code file already exists}
  1054.          ErrorCode := Return_Code;
  1055.          EXIT;                     {bailout before we Bombout}
  1056.       END;
  1057.    DOS_Return_Code := False;       {false so copyfile will work anyway}
  1058.    Assign(FileIn,Input_File);      {tell TP4 about the input file}
  1059.    Assign(FileOut,Output_File);    { ''   ''   ''   '  oputput file}
  1060.    {$I-}
  1061.    Reset(FileIn);   {does such a file really exist?}
  1062.    {$I+}
  1063.    Return_Code := IOresult;
  1064.    IF (Return_Code = 0) THEN  {if it does then we can proceed}
  1065.     BEGIN
  1066.        IF EraseInputFile THEN             { if we want to erase the input file }
  1067.           BEGIN
  1068.              Input_File:=Input_File+Chr(0);  { then we will try the dos rename    }
  1069.              OutPut_File:=OutPut_File+Chr(0);{ function first. This will move or  }
  1070.              Regs.Ah:=$56;                   { change the files directory and not }
  1071.              Regs.DS:=seg(Input_File);       { take time copying the actual file  }
  1072.              Regs.Dx:=ofs(Input_File[1]);    { data.                              }
  1073.              Regs.ES:=seg(OutPut_File);
  1074.              Regs.DI:=ofs(OutPut_File[1]);
  1075.              MsDos(Regs);
  1076.              IF Regs.AX = 0 THEN DOS_Return_Code := True
  1077.                             ELSE DOS_Return_Code := False;{not the same drive}
  1078.          END;
  1079.  
  1080.        IF NOT DOS_Return_Code THEN {dos couldn't do it so we'll copy the data}
  1081.        BEGIN                       {or we want a carbon copy of the file}
  1082.           ReWrite(FileOut);   {create the output file}
  1083.           New(CopyBufrPtr);   {initialize our copy buffer}
  1084.           REPEAT
  1085.              Blockread(FileIn,CopyBufrPtr^,RecordNum,RecordCount);
  1086.              {read data in}
  1087.              Blockwrite(FileOut,CopyBufrPtr^,RecordCount);
  1088.              {write data out}
  1089.           UNTIL RecordCount = 0;
  1090.           Dispose(CopyBufrPtr);  {give up our buffer memory to dos}
  1091.           Close(FileIn);
  1092.           Close(FileOut);
  1093.           IF EraseInputFile THEN {$I-}Erase(filein){$I+};
  1094.           ErrorCode := IOresult;
  1095.           Return_Code := ErrorCode;
  1096.        END;   { this is your basic copyfile example with additions and subs }
  1097.     END;      { better error checking and assorted features could still be  }
  1098. END;          { to enhance the performance of this routine.                 }
  1099.  
  1100.  
  1101. (*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  1102. FUNCTION IntToHex;
  1103. CONST
  1104.      HexChars: ARRAY[0..15] of char ='0123456789ABCDEF';
  1105. VAR
  1106.    Temp:Byte;
  1107.    TempStr:String[2];
  1108. BEGIN
  1109.    Temp:=Hi(IntNum); {get and convert hi byte to hex}
  1110.    TempStr:=HexChars[Temp shr 4]+HexChars[Temp and $0F];
  1111.    Temp:=lo(IntNum); {get and convert lo byte to hex}
  1112.    IntToHex:=TempStr+HexChars[Temp shr 4]+HexChars[Temp and $0F];
  1113. END;
  1114.  
  1115.  
  1116. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  1117. FUNCTION PIKDIR(Path:String;IncludeDir:Boolean):String;
  1118.  
  1119. PROCEDURE Hilite(X:Integer);
  1120. VAR
  1121.    Xcord,Row:Integer;
  1122. BEGIN
  1123.    Xcord:=(Trunc((X-1)/17)*15)+5;    {set col position for hiliting }
  1124.    Row:=(X-(17*Trunc((X-1)/17)))+4;  {set row position for   "      }
  1125.    KAttr(Row,Xcord,1,12,79);         {hilite the position}
  1126. END;
  1127.  
  1128. PROCEDURE LoLite(X:Integer);
  1129. VAR
  1130.    Xcord,Row:Integer;
  1131. BEGIN
  1132.    Xcord:=(Trunc((X-1)/17)*15)+5;    {set col position for loliting }
  1133.    Row:=(X-(17*Trunc((X-1)/17)))+4;  {set row position for   "      }
  1134.    KAttr(Row,Xcord,1,12,14); {hilite the position}
  1135. END;
  1136.  
  1137. VAR
  1138.    One:AllFiles;
  1139.    X,Y,N:Integer;
  1140.    TempCounter,Start,Counter,Counter2,Total:Integer;
  1141.    More,Temp:String;
  1142.    MoreD,Done:Boolean;
  1143.    Position,OldPosition,Old2Position,Old3Position,
  1144.    Old4Position,Old5Position,ULRBox,ULCBox,LRRBox,LRCBox:Integer;
  1145.    C:Char;
  1146.    Near,Far:Byte;
  1147.    SavedTxtAttr:Byte;
  1148.    MainScr,BoxScr: SaveScrType;
  1149.  
  1150.  
  1151. PROCEDURE MakeBox;
  1152. VAR
  1153.    X,Y,N:Integer;
  1154. BEGIN
  1155.    SavedTxtAttr := TextAttr;                  {makebox goes thru the process }
  1156.    TextAttr := 14;                            {of determining the box size that}
  1157.    IF Counter>17 THEN Y:=Trunc(Counter/17)+1  {we will need to hold all the }
  1158.                  ELSE Y:=1;                   {listings, as it writes the   }
  1159.    Start:=10;                                 {entries on the screen.      }
  1160.    N:=Y;
  1161.    IF Y>5 THEN Y:=5;
  1162.    IF Counter>17 THEN Far:=22
  1163.                  ELSE Far:=Counter+5;
  1164.    Near:=(Y*15)+3;
  1165.    ULRBox := 4;
  1166.    ULCBox := 3;
  1167.    LRRBox := Far-3;
  1168.    LRCBox := Near-2;
  1169.    KSaveScr(ULRBox,ULCBox,LRRBox,LRCBox,BoxScr);
  1170.    KBox(ULRBox,ULCBox,LRRBox,LRCBox,29,14,Border2,True);
  1171.    Y:=N;
  1172.    CursorOff;
  1173.    FOR N:=1 TO Y DO
  1174.     FOR X:=1 TO 17 DO
  1175.     BEGIN
  1176.        Total:=Total+1;
  1177.        GotoXy(5+((N-1)*15),X+4);
  1178.        IF (Total<=Counter) AND (Total<86) THEN Write(One[Total]);
  1179.        IF (MoreD) AND ((Counter+85)>=Total) THEN Write(One[Total]);
  1180.     END;
  1181.    Done:=False;
  1182.    TextAttr := SavedTxtAttr;
  1183.    Hilite(Position);
  1184. END;
  1185.  
  1186.  
  1187. BEGIN
  1188.    DirFill(Path,One,Counter,IncludeDIR);
  1189.    {fill array ONE with listings in PATH}
  1190.    SortDir(One,Counter);      {sort the array}
  1191.    Total:=0;
  1192.    MoreD:=False;
  1193.    NEW(MainScr);
  1194.    KSaveScr(1,1,25,80,MainScr);
  1195.    Position:=1;
  1196.    OldPosition:=1;
  1197.    NEW(BoxScr);
  1198.    MakeBox;
  1199.    REPEAT
  1200.       IF KeyPressed THEN
  1201.        BEGIN
  1202.           C:=ReadKey;
  1203.           IF C=#13 THEN
  1204.            BEGIN
  1205.               IF MoreD THEN Position:=Position+85;
  1206.               IF One[Position][1]<>'<' THEN
  1207.                BEGIN
  1208.                   Temp:='';
  1209.                   FOR X:=1 TO Length(Path)-3 DO
  1210.                       Temp:=Temp+Path[X];
  1211.                   Path:=Temp+One[Position];
  1212.                   PikDir := Path;
  1213.                   DONE := True;
  1214.                END
  1215.                                        ELSE
  1216.                BEGIN
  1217.                   Temp:='';
  1218.                   FOR X:=1 TO Length(Path)-4 DO
  1219.                       Temp:=Temp+Path[X];
  1220.                   Path:=Temp;
  1221.                   Temp:='';
  1222.                   FOR X:=1 TO Length(One[Position]) DO
  1223.                       IF (One[Position][X]<>'<') AND (One[Position][X]<>'>') THEN Temp:=Temp+One[Position][X];
  1224.                   IF Temp<>'..' THEN
  1225.                      BEGIN
  1226.                         Path:=Path+'\'+Temp+'\*.*';
  1227.                         Old5Position:=Old4Position;
  1228.                         Old4Position:=Old3Position;
  1229.                         Old3Position:=Old2Position;
  1230.                         Old2Position:=OldPosition;
  1231.                         OldPosition:=Position;
  1232.                         Position:=1;
  1233.                      END
  1234.                                 ELSE
  1235.                      BEGIN
  1236.                         X:=Length(Path)+1;
  1237.                         REPEAT
  1238.                            X:=X-1;
  1239.                         UNTIL Path[X]='\';
  1240.                         Path:=Copy(Path,1,X);
  1241.                         Path:=Path+'*.*';
  1242.                         Position:=OldPosition;
  1243.                         OldPosition:=Old2Position;
  1244.                         Old2Position:=Old3Position;
  1245.                         Old3Position:=Old4Position;
  1246.                         Old4Position:=Old5Position;
  1247.                      END;
  1248.                   KRestoreScr(BoxScr);
  1249.                   DirFill(Path,One,Counter,IncludeDIR);
  1250.                   SortDir(One,Counter);
  1251.                   Total:=0;
  1252.                   MoreD:=False;
  1253.                   MakeBox;
  1254.                END;
  1255.            END;
  1256.           IF C=#0 THEN
  1257.            BEGIN
  1258.               Lolite(Position);
  1259.               C:=ReadKey;
  1260.               IF C=#68 THEN Done:=True;
  1261.               IF C=#80 THEN Position:=Position+1;
  1262.               IF C=#72 THEN Position:=Position-1;
  1263.               IF C=#75 THEN Position:=Position-17;
  1264.               IF C=#77 THEN Position:=Position+17;
  1265.               IF C=#73 THEN
  1266.                BEGIN
  1267.                   IF MoreD THEN
  1268.                    BEGIN
  1269.                       Counter:=TempCounter;
  1270.                       Total:=0;
  1271.                       KRestoreScr(BoxScr);
  1272.                       MoreD:=False;
  1273.                       Position:=1;
  1274.                       MakeBox;
  1275.                    END;
  1276.                END;
  1277.               IF C=#81 THEN
  1278.                BEGIN
  1279.                   IF Counter>85 THEN
  1280.                    BEGIN
  1281.                       TempCounter:=Counter;
  1282.                       Counter:=Counter-85;
  1283.                       KRestoreScr(BoxScr);
  1284.                       Total:=85;
  1285.                       MoreD:=True;
  1286.                       Position:=1;
  1287.                       MakeBox;
  1288.                    END;
  1289.                END;
  1290.               IF Position<1 THEN Position:=1;
  1291.               IF Position>Counter THEN Position:=Counter;
  1292.               IF Position>85 THEN Position:=85;
  1293.               HiLite(Position);
  1294.            END;
  1295.  
  1296.        END;
  1297.    UNTIL Done;
  1298.    KRestoreScr(MainScr); {replace the main screen }
  1299.    DISPOSE(BoxScr);      {free up heap space}
  1300.    DISPOSE(MainScr);
  1301. END;
  1302.  
  1303. (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
  1304. (*
  1305.    This is done to initialize the ActiveDp and LineWidth variables when the
  1306.    program is first run.  The VideoMode variable may also be used along with
  1307.    ActiveDP & LineWidth.
  1308. *)
  1309.  
  1310. BEGIN
  1311.    DirectVideo := TRUE;
  1312.    VideoMode := CurrentVideoMode;
  1313. END.
  1314.  
  1315. (******************************************************************************
  1316.  
  1317. Additions & Revisions
  1318. ~~~~~~~~~~~~~~~~~~~~~
  1319.  
  1320. {010188 ver 2.0}
  1321. Changed KFill : placed number of cols to fill in CX versa advancing cursor and
  1322. writing one position per call to BIOS. I originally thought this would show how
  1323. to use the bios calls to write to different x/y positions, however it was just
  1324. to slow to be truly useful.  The current code shows the use of the bios call
  1325. plus the use of the CX register in this type of bios function.
  1326.  
  1327. Added Function : KUCase,KLCase & Color.
  1328.  
  1329. {010688 ver 2.1}
  1330. Fixed bug in KTrim.  Trailing blanks were not being seen inside FOR loop.
  1331.  
  1332. Fixed bug in KBox which was advancing the screen one row when the 25,80 was
  1333. passed as the bottom right corner of the box.
  1334.  
  1335. {010788 ver 2.2}
  1336. Added Function : KVertMenu & KHorizMenu
  1337.  
  1338. {011188 ver 3.0}
  1339. Added KSaveScr & KRestoreScr
  1340. Added Functions for light pen use.
  1341. Added IntoHex,Space,CopyFile
  1342. Added DirFill,SortDir,PikDir
  1343.  
  1344. My close friend and associate "Gary Smith" offered the use of his DIR. routines
  1345. for KTOOLS.  The originals remain with him.  I have modified these for use in
  1346. the KTOOLS package and offer him my sincere thanks.
  1347. "The Programmer's Corner"
  1348. 300-2400 (301)794-4331
  1349. Sysop(Gary Smith)
  1350. ******************************************************************************)
  1351.