home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / top2src.zip / BJ4TOP.ZIP / BJSUPP.PAS < prev    next >
Pascal/Delphi Source File  |  1996-01-02  |  4KB  |  182 lines
  1. Unit BJSupp;
  2. {========================================================================}
  3.                               INTERFACE
  4. {========================================================================}
  5. Uses Crt, Dos;
  6.  
  7. Function CStr (var s : string) : String;
  8. Function FExists(FileName: string) : Boolean;
  9. Function KillTOPCodes (s : String) : String;
  10. Function KillSpaces (s : String) : String;
  11. Function Minus1 (s : string) : String;
  12. Function PaddedNum (I : byte) : String;
  13. Function Spaces (num : byte) : string;
  14. Function ToStr (Number : LongInt) : String;
  15. Function UpStr (s : string) : String;
  16. Procedure WindowBorder (x : byte; y : byte; x2 : byte; y2 : byte;
  17.                         Fcolor : byte; Bcolor: Byte);
  18. Procedure TimeSlice (num : byte);
  19.  
  20. {========================================================================}
  21.                             IMPLEMENTATION
  22. {========================================================================}
  23.  
  24. Function CStr (var s : string) : String;
  25. Var
  26.   l : byte;
  27.   OutStr : String;
  28. begin
  29.   l := 0;
  30.   While (s[l] <> #0) do
  31.   begin
  32.     Inc (l);
  33.     OutStr[L] := s[l-1];
  34.   end;
  35.   OutStr[0] := Chr(L);
  36.   CStr := OutStr;
  37. end;
  38.  
  39. Function FExists(FileName: string) : Boolean;
  40. Var
  41.   f: file;
  42. begin
  43.   {$I-}
  44.   Assign(f, FileName);
  45.   Reset(f);
  46.   Close(f);
  47.   {$I+}
  48.   FExists := (IOResult = 0) and (FileName <> '');
  49. end;
  50.  
  51. Function KillTOPCodes (s : String) : String;
  52. begin
  53.   While Pos ('^',s) <> 0 do
  54.     Delete (s, Pos ('^',s), 2);
  55.   While s[Length(s)] = #32 do Dec (s[0]);
  56.   KillTOPCodes := s;
  57. end;
  58.  
  59. Function KillSpaces (s : String) : String;
  60. begin
  61.   While Pos(' ',s) <> 0 do
  62.     Delete (s, Pos (' ',s), 1);
  63.   While s[Length(s)] = #32 do Dec (s[0]);
  64.   KillSpaces := s;
  65. end;
  66.  
  67. Function Minus1 (s : string) : String;
  68. Var
  69.   New : String;
  70.   I : byte;
  71. begin
  72.   FillChar (New, SizeOf (New), #0);
  73.   For I := 2 to Length (s) do New[I-1] := s[I];
  74.   New[0] := Chr(Length (s) - 1);
  75.   Minus1 := New;
  76. end;
  77.  
  78. Function PaddedNum (I : byte) : String;
  79. Var
  80.   s : String;
  81. begin
  82.   Str (I,s);
  83.   If I < 10 then s := '0'+s;
  84.   If I < 100 then s := '0'+s;
  85.   If I < 1000 then s := '0'+s;
  86.   If I < 10000 then s := '0'+s;
  87.   PaddedNum := s;
  88. end;
  89.  
  90. Function Spaces (num : byte) : string;
  91. Var
  92.   L : byte;
  93.   s : String;
  94. begin
  95.   s := '';
  96.   For L := 1 to num do s := s + ' ';
  97.   Spaces := s;
  98. end;
  99.  
  100. Function ToStr (Number : LongInt) : String;
  101. Var
  102.   a_str : String;
  103. begin
  104.   Str (Number, a_str);
  105.   ToStr := a_str;
  106. end;
  107.  
  108. Function UpStr (s : string) : String;
  109. Var
  110.   L : byte;
  111. begin
  112.   For L := 1 to Length (s) do s[l] := Upcase (s[l]);
  113.   UpStr := s;
  114. end;
  115.  
  116. Procedure WindowBorder (x : byte; y : byte; x2 : byte; y2 : byte;
  117.                         Fcolor : byte; Bcolor: Byte);
  118. Var
  119.   Loop : Byte;
  120.   VideoMem : Array [1..4000] of byte absolute $B800:0000;
  121.  
  122. begin { Window Border }
  123.   { Change to user specified colors }
  124.   Textcolor (FColor);  Textbackground (BColor);
  125.   { Clear region for background color }
  126.   Window (x,y,x2,y2);
  127.   ClrScr;
  128.   { Restore Window }
  129.   Window (1,1,80,25);
  130.   { Draw borders }
  131.   GotoXY (x,y);
  132.   Write ('┌');
  133.   For Loop := (x+1) to (x2-1) do
  134.   begin
  135.     GotoXY (loop, y);
  136.     Write ('─');
  137.   end;
  138.   GotoXY (x2,y);
  139.   Write ('┐');
  140.   For Loop := (y+1) to (y2-1) do
  141.   begin
  142.     GotoXY (x, loop);
  143.     Write ('│');
  144.   end;
  145.   GotoXY (x,y2);
  146.   Write ('└');
  147.   For Loop := (x+1) to (x2-1) do
  148.   begin
  149.     GotoXY (loop,y2);
  150.     Write ('─');
  151.   end;
  152.   GotoXY (x2,y2);
  153.   Write ('┘');
  154.   For Loop := (y+1) to (y2-1) do
  155.   begin
  156.     GotoXY (x2,loop);
  157.     Write ('│');
  158.   end;
  159.   { Do horizontal shadow }
  160.   For Loop := (x+2) to (x2+2) do VideoMem [2*Loop+Y2*160] := $08;
  161.   { Do vertical shadow }
  162.   For Loop := (y+1) to (y2) do
  163.   begin
  164.     VideoMem [2*(X2+1)+Loop*160] := $08;
  165.     VideoMem [(2*(X2+1)+Loop*160)+2] := $08;
  166.   end;
  167. end; { Window Border }
  168.  
  169. Procedure TimeSlice(num : byte);
  170. var d: byte;
  171. begin
  172.     for d := 0 to (num - 1) do
  173.     begin
  174.       asm
  175.         mov ax, 01680h
  176.         int 02fh
  177.       end
  178.   end
  179. end;
  180.  
  181. end.
  182.