home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / INTERU.ZIP / CURSORS.PAS next >
Encoding:
Pascal/Delphi Source File  |  1988-03-10  |  2.9 KB  |  132 lines
  1. {$R-,S-,I-,D-,T-,F-,V-,B-,N-}
  2.  
  3. unit Cursors;
  4.  
  5. { A unit for changing the appearance of the display cursor.
  6.  
  7.   Version 1.02 - 10/26/1987 - First general release
  8.  
  9.   Scott Bussinger
  10.   Professional Practice Systems
  11.   110 South 131st Street
  12.   Tacoma, WA  98444
  13.   (206)531-8944
  14.   Compuserve 72247,2671 }
  15.  
  16.  
  17. interface
  18.  
  19. uses Dos;
  20.  
  21. type CursorSize = word;
  22.      CursorType = (UnderlineCursor,BlockCursor,NoCursor,RestoreCursor);
  23.  
  24. procedure GetCursor(var Curs: CursorSize);
  25.   { Get the current cursor size }
  26.  
  27. procedure SetCursor(Curs: CursorSize);
  28.   { Set the current cursor size }
  29.  
  30. procedure MakeCursor(CursType: CursorType);
  31.   { Set the cursor to the indicated style -- adjusts for display type }
  32.  
  33. procedure GetCursorLoc(var Row,Column: byte);
  34.   { Return the current cursor location }
  35.  
  36. procedure SetCursorLoc(Row,Column: byte);
  37.   { Move the cursor to the given location }
  38.  
  39. function MonoDisplay: boolean;
  40.   { Return true if the current display is a monochrome adapter }
  41.  
  42. implementation
  43.  
  44. var ExitSave: pointer;
  45.     OriginalCursor: CursorSize;
  46.  
  47. function MonoDisplay: boolean;
  48.   { Return true if the current display is a monochrome adapter }
  49.   var Reg: Registers;
  50.   begin
  51.   Reg.AH := $0F;
  52.   Intr($10,Reg);
  53.   MonoDisplay := Reg.AL = 7
  54.   end;
  55.  
  56. procedure GetCursor(var Curs: CursorSize);
  57.   { Get the current cursor size }
  58.   var Reg: Registers;
  59.   begin
  60.   Reg.AH := $03;
  61.   Reg.BH := $00;
  62.   Intr($10,Reg);
  63.   if (Reg.CX=$0607) and MonoDisplay
  64.    then
  65.     Curs := $0C0D                                { Watch out for bug in DOS }
  66.    else
  67.     Curs := Reg.CX
  68.   end;
  69.  
  70. procedure SetCursor(Curs: CursorSize);
  71.   { Set the current cursor size }
  72.   var Reg: Registers;
  73.   begin
  74.   Reg.AH := $01;
  75.   Reg.CX := Curs;
  76.   Intr($10,Reg)
  77.   end;
  78.  
  79. procedure MakeCursor(CursType: CursorType);
  80.   { Set the cursor to the indicated style -- adjusts for display type }
  81.   var LastLine: CursorSize;
  82.   begin
  83.   if MonoDisplay
  84.    then
  85.     LastLine := $000D
  86.    else
  87.     LastLine := $0007;
  88.   case CursType of
  89.     UnderlineCursor: SetCursor(swap(pred(LastLine)) + LastLine);
  90.     BlockCursor: SetCursor(LastLine);
  91.     NoCursor: SetCursor($2000);
  92.     RestoreCursor: SetCursor(OriginalCursor)
  93.     end
  94.   end;
  95.  
  96. procedure GetCursorLoc(var Row,Column: byte);
  97.   { Return the current cursor location }
  98.   var Reg: Registers;
  99.   begin
  100.   Reg.AH := $03;
  101.   Reg.BH := $00;
  102.   Intr($10,Reg);
  103.   Row := succ(Reg.DH);
  104.   Column := succ(Reg.DL)
  105.   end;
  106.  
  107. procedure SetCursorLoc(Row,Column: byte);
  108.   { Move the cursor to the given location }
  109.   var Reg: Registers;
  110.   begin
  111.   Reg.AH := $02;
  112.   Reg.BH := $00;
  113.   Reg.DL := pred(Column);
  114.   Reg.DH := pred(Row);
  115.   Intr($10,Reg)
  116.   end;
  117.  
  118. {$F+}
  119. procedure ExitHandler;
  120.   { Return the cursor to its original shape }
  121.   begin
  122.   MakeCursor(RestoreCursor);
  123.   ExitProc := ExitSave
  124.   end;
  125. {$F-}
  126.  
  127. begin
  128. ExitSave := ExitProc;
  129. ExitProc := @ExitHandler;
  130. GetCursor(OriginalCursor)
  131. end.
  132.