home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / top2src.zip / TOPLINK.ZIP / TOPLSUPP.PAS < prev    next >
Pascal/Delphi Source File  |  1996-05-29  |  10KB  |  398 lines
  1. Unit TOPLSupp;
  2. {========================================================================}
  3.                               INTERFACE
  4. {========================================================================}
  5. Uses Crt, Dos, MulAware;
  6.  
  7. Function Ask2Save : Boolean;
  8. Function CStr (var s : string) : String;
  9. Procedure CursorNorm;
  10. Procedure CursorOff;
  11. Function FExists(FileName: string) : Boolean;
  12. Function Get_Key : Word;
  13. Procedure GetString (var UntypedString; Max_Length : Byte; Default : String);
  14. Function KillAnsi (s : String) : String;
  15. Function KillTOPCodes (s : String) : String;
  16. Function Minus1 (s : string) : String;
  17. Function MultiTaskerStr : String;
  18. Function PaddedNum (I : Integer) : String;
  19. Function Spaces (num : byte) : string;
  20. Function ToStr (Number : LongInt) : String;
  21. Function UpStr (s : string) : String;
  22. Function VersionStr : String;
  23. Procedure WindowBorder (x : byte; y : byte; x2 : byte; y2 : byte;
  24.                         Fcolor : byte; Bcolor: Byte);
  25. Procedure SaveScreen (var Scr);        { Scr is an array [1..4000] of byte }
  26. Procedure RestoreScreen (var Scr);     { or char }
  27. function FLock(Lock:byte; Handle: Word; Pos,Len: LongInt): Word;
  28.  
  29. {========================================================================}
  30.                             IMPLEMENTATION
  31. {========================================================================}
  32.  
  33. Function Ask2Save : Boolean;
  34. Var
  35.   Key : Char;
  36. begin
  37.   WindowBorder (22,6,42,8,White, Blue);
  38.   GotoXY (23,7);
  39.   CursorNorm;
  40.   Write ('Save Changes (Y/N)');
  41.   Repeat
  42.     key := Upcase (Readkey);
  43.   Until Key in ['Y','N'];
  44.   If Key = 'Y' then Ask2Save := True else Ask2Save := False;
  45.   TextAttr := $07;
  46.   ClrScr;
  47. end;
  48.  
  49. Function CStr (var s : string) : String;
  50. Var
  51.   l : byte;
  52.   OutStr : String;
  53. begin
  54.   l := 0;
  55.   While (s[l] <> #0) do
  56.   begin
  57.     Inc (l);
  58.     OutStr[L] := s[l-1];
  59.   end;
  60.   OutStr[0] := Chr(L);
  61.   CStr := OutStr;
  62. end;
  63.  
  64. Procedure CursorOff;
  65. Var
  66.   Reg : Registers;
  67. begin
  68.   Reg.Ax := 1 shl 8;
  69.   Reg.Cx := $14 shl 8;
  70.   Intr ($10, Reg);
  71. end;
  72.  
  73. Procedure CursorNorm;
  74. Var
  75.   Reg : Registers;
  76. begin
  77.   Reg.Ax := 1 shl 8;
  78.   Reg.Cx := 6 shl 8 + 7;
  79.   Intr ($10, Reg);
  80. end;
  81.  
  82. Function FExists(FileName: string) : Boolean;
  83. Var
  84.   f: file;
  85. begin
  86.   {$I-}
  87.   Assign(f, FileName);
  88.   Reset(f);
  89.   Close(f);
  90.   {$I+}
  91.   FExists := (IOResult = 0) and (FileName <> '');
  92. end;
  93.  
  94. Function Get_Key : Word;
  95. Var
  96.   a_key : char;
  97. begin
  98.   a_key := Readkey;
  99.   if a_key = #0 then
  100.   begin
  101.     a_key := Readkey;
  102.     Get_Key := Ord (a_key) + 256
  103.   end
  104.   else Get_Key := Ord (a_key);
  105. end;
  106.  
  107. Function KillAnsi (s : String) : String;
  108. Var
  109.   L : byte;
  110. begin
  111.   While Pos (#27,s) <> 0 do
  112.   begin
  113.     L := Pos (#27,s);
  114.     Repeat
  115.       Inc (L);
  116.     Until not (S[L] in ['0'..'9',';','[']);
  117.     Inc (l);
  118.     Delete (s, Pos (#27,s), L - Pos (#27,s));
  119.   end;
  120.   While s[Length(s)] = #32 do Dec (s[0]);
  121.   KillAnsi := s;
  122. end;
  123.  
  124. Function KillTOPCodes (s : String) : String;
  125. Var
  126.   L : byte;
  127. begin
  128.   While Pos ('^',s) <> 0 do
  129.     Delete (s, Pos ('^',s), 2);
  130.   While s[Length(s)] = #32 do Dec (s[0]);
  131.   KillTOPCodes := s;
  132. end;
  133.  
  134. Procedure GetString (var UntypedString; Max_Length : Byte; Default : String);
  135. Const
  136.   Valid_Characters : Set of Char = [#1..#12,#14..#26, #28..#254];
  137. Var
  138.   ch : Char;
  139.   s : String[1];
  140.   CursorPos : Byte;
  141.   x,y : Byte;
  142.   l : Byte;
  143.   a_string : String Absolute UntypedString;
  144.   Old : String;
  145.   First : Boolean;
  146.  
  147. Begin
  148.   Old := A_String;
  149.   X := WhereX;
  150.   Y := WhereY;
  151.   First := True;
  152.   if Default[1] in Valid_Characters then a_string := Default else a_string[0] := #0;
  153.   For l := Ord (a_string[0]) + 1 to Max_Length do a_string[l] := #32;
  154.   a_string[0] := chr (max_length);
  155.   Write (a_string);
  156.   CursorPos := Max_length;
  157.   While a_string[CursorPos - 1] = #32 do dec (CursorPos);
  158.   GotoXY (X + CursorPos - 1, y);
  159.   repeat
  160.     If (Ord (a_string[0]) = Max_Length) and (a_string[Max_length] = #32) then Dec (a_string[0]);
  161.     ch := Readkey;
  162.     If First AND ((ch = #8) OR ((ch in Valid_Characters) AND (ch >= #32))) then
  163.     begin
  164.       a_string := '';
  165.       GotoXY (x,y);
  166.       CursorPos := 1;
  167.       For L := 1 to Max_Length do Write (' ');
  168.       GotoXY (x,y);
  169.     end;
  170.     if (ch = #8) then
  171.     begin
  172.       if CursorPos <> 1 then
  173.       begin
  174.         Dec (CursorPos);
  175.         Delete (a_string, CursorPos, 1);
  176.         GotoXY (X,Y);
  177.         Write (a_string + ' ');
  178.         GotoXY (X + CursorPos - 1, y);
  179.       end;
  180.     end
  181.     else
  182.     begin
  183.       If ch in Valid_Characters then
  184.       begin
  185.         if (CursorPos < Max_Length+1) and (Length (a_string) < Max_Length) and
  186.         (ch <> #13) then
  187.         begin
  188.           S := ch;
  189.           Insert (s, a_string, CursorPos);
  190.           GotoXY (X,Y);
  191.           Write (a_string);
  192.           GotoXY (X + CursorPos,y);
  193.           Inc (CursorPos);
  194.         end;
  195.       end;
  196.       If ch = #27 then
  197.       begin
  198.         a_string := old;
  199.         ch := #13;
  200.       end;
  201.       If ch = #0 then
  202.       begin
  203.         ch := Readkey;
  204.         Case ch of
  205.           'K' : If CursorPos > 1 then Dec (CursorPos);
  206.           'M' : If CursorPos < Max_Length then Inc (CursorPos);
  207.           'S' :
  208.           begin
  209.             if a_string <> '' then
  210.             begin
  211.               Delete (a_string, CursorPos, 1);
  212.               GotoXY (X,Y);
  213.               Write (a_string + ' ');
  214.             end;
  215.           end;
  216.           'G' : CursorPos := 1;
  217.           'O' :
  218.           begin
  219.             CursorPos := Max_length;
  220.             While a_string[CursorPos - 1] = #32 do dec (CursorPos);
  221.           end;
  222.         end;
  223.         GotoXY (X + CursorPos - 1, y);
  224.       end;
  225.     end;
  226.     First := False;
  227.   Until (ch = #13);
  228.   While a_string[Length(a_string)] = #32 do Dec (a_string[0]);
  229.   GotoXY (X,Y);
  230. end;
  231.  
  232. Function Minus1 (s : string) : String;
  233. Var
  234.   New : String;
  235.   I : byte;
  236. begin
  237.   FillChar (New, SizeOf (New), #0);
  238.   For I := 2 to Length (s) do New[I-1] := s[I];
  239.   New[0] := Chr(Length (s) - 1);
  240.   Minus1 := New;
  241. end;
  242.  
  243. Function MultiTaskerStr : String;
  244. Var
  245.   a_str : String;
  246. begin
  247.   Case MultiTasker of
  248.     None         : A_Str := 'DOS';
  249.     DESQview     : A_Str := 'DESQview';
  250.     WinEnh,WinStandard : A_Str := 'Windows';
  251.     OS2          : A_Str := 'OS/2';
  252.     DoubleDOS    : A_Str := 'DoubleDOS';
  253.     MultiDos     : A_Str := 'MultiDos Plus';
  254.     VMiX         : A_Str := 'VMiX';
  255.     TopView      : begin
  256.                      If MulVersion <> 0 then
  257.                         A_Str := 'TopView'
  258.                      Else
  259.                         A_Str := 'TaskView, DESQview 2.00-2.25, OmniView, or Compatible';
  260.                    end;
  261.     TaskSwitcher : A_Str := 'DOS 5.0 Task Switcher or Compatible';
  262.     WinNT        : A_Str := 'Windows NT';
  263.   end;
  264.   MultiTaskerStr := A_Str;
  265. end;
  266.  
  267. Function PaddedNum (I : Integer) : String;
  268. Var
  269.   s : String;
  270. begin
  271.   Str (I,s);
  272.   If I < 10 then s := '0'+s;
  273.   If I < 100 then s := '0'+s;
  274.   If I < 1000 then s := '0'+s;
  275.   If I < 10000 then s := '0'+s;
  276.   PaddedNum := s;
  277. end;
  278.  
  279. Function Spaces (num : byte) : string;
  280. Var
  281.   L : byte;
  282.   s : String;
  283. begin
  284.   s := '';
  285.   For L := 1 to num do s := s + ' ';
  286.   Spaces := s;
  287. end;
  288.  
  289. Function ToStr (Number : LongInt) : String;
  290. Var
  291.   a_str : String;
  292. begin
  293.   Str (Number, a_str);
  294.   ToStr := a_str;
  295. end;
  296.  
  297. Function UpStr (s : string) : String;
  298. Var
  299.   L : byte;
  300. begin
  301.   For L := 1 to Length (s) do s[l] := Upcase (s[l]);
  302.   UpStr := s;
  303. end;
  304.  
  305. Function VersionStr : String;
  306. Var
  307.   A_Str : String;
  308.  
  309. begin
  310.   If MultiTasker <> None then VersionStr := ToStr (Hi (MulVersion)) + '.' + ToStr (Lo (MulVersion))
  311.   else VersionStr := ToStr (Lo (DosVersion)) + '.' + ToStr (Hi (DosVersion));
  312. end;
  313.  
  314. Procedure WindowBorder (x : byte; y : byte; x2 : byte; y2 : byte;
  315.                         Fcolor : byte; Bcolor: Byte);
  316. Var
  317.   Loop : Byte;
  318.   VideoMem : Array [1..4000] of byte absolute $B800:0000;
  319.  
  320. begin { Window Border }
  321.   { Change to user specified colors }
  322.   Textcolor (FColor);  Textbackground (BColor);
  323.   { Clear region for background color }
  324.   Window (x,y,x2,y2);
  325.   ClrScr;
  326.   { Restore Window }
  327.   Window (1,1,80,25);
  328.   { Draw borders }
  329.   GotoXY (x,y);
  330.   Write ('┌');
  331.   For Loop := (x+1) to (x2-1) do
  332.   begin
  333.     GotoXY (loop, y);
  334.     Write ('─');
  335.   end;
  336.   GotoXY (x2,y);
  337.   Write ('┐');
  338.   For Loop := (y+1) to (y2-1) do
  339.   begin
  340.     GotoXY (x, loop);
  341.     Write ('│');
  342.   end;
  343.   GotoXY (x,y2);
  344.   Write ('└');
  345.   For Loop := (x+1) to (x2-1) do
  346.   begin
  347.     GotoXY (loop,y2);
  348.     Write ('─');
  349.   end;
  350.   GotoXY (x2,y2);
  351.   Write ('┘');
  352.   For Loop := (y+1) to (y2-1) do
  353.   begin
  354.     GotoXY (x2,loop);
  355.     Write ('│');
  356.   end;
  357.   { Do horizontal shadow }
  358.   For Loop := (x+2) to (x2+2) do VideoMem [2*Loop+Y2*160] := $08;
  359.   { Do vertical shadow }
  360.   For Loop := (y+1) to (y2) do
  361.   begin
  362.     VideoMem [2*(X2+1)+Loop*160] := $08;
  363.     VideoMem [(2*(X2+1)+Loop*160)+2] := $08;
  364.   end;
  365. end; { Window Border }
  366.  
  367. Procedure RestoreScreen (var Scr);
  368. begin
  369.   If Lastmode <> 7 then Move (Scr, Ptr ($B800,0000)^, 4000)
  370.   else Move (Scr, Ptr ($B000,0000)^, 4000);
  371. end;
  372.  
  373. Procedure SaveScreen (var Scr);
  374. begin
  375.   If Lastmode <> 7 then Move (Ptr ($B800,0000)^, Scr, 4000)
  376.   else Move (Ptr ($B000,0000)^, Scr, 4000);
  377. end;
  378.  
  379. function FLock(Lock:byte; Handle: Word; Pos,Len: LongInt): Word; (* Assembler;
  380.   ASM
  381.       mov   AL,Lock   { subfunction 0: lock region   }
  382.                       { subfunction 1: unlock region }
  383.       mov   AH,$5C    { DOS function $5C: FLOCK    }
  384.       mov   BX,Handle { put FileHandle in BX       }
  385.       les   DX,Pos
  386.       mov   CX,ES     { CX:DX begin position       }
  387.       les   DI,Len
  388.       mov   SI,ES     { SI:DI length lockarea      }
  389.       int   $21       { Call DOS ...               }
  390.       jb    @End      { if error then return AX    }
  391.       xor   AX,AX     { else return 0              }
  392.   @End:*)
  393. begin
  394. FLock := 0;
  395. end {FLock};
  396.  
  397. end.
  398.