CRT32

Delphi 32 version of the Pascal CRT unit.

Contributor: FRANK ZIMMER





Implementation of Turbo Pascal CRT-Unit for Win32

Console Subsystem



_________________ Make file CRT32.inf ________________________________

filename=Crt32

replacements=

fileversion=1.0.0127

filedescription=Implementation of Turbo Pascal CRT-Unit for Win32 Console Subsystem

target=Delphi 2.0

author name=Frank Zimmer

author e-mail=fzimmer@compuserve.com

autor URL=

file status=freeware

full source=

category=Miscellaneous



_________________ Make file CRT32.int ________________________________

{$APPTYPE CONSOLE}

unit crt32;

{# freeware}

{# version 1.0.0127}

{# Date 18.01.1997}

{# Author Frank Zimmer}

{# description

 Copyright © 1997, Frank Zimmer, 100703.1602@compuserve.com

 Version: 1.0.0119

 Date: 18.01.1997



 an Implementation of Turbo Pascal CRT-Unit for Win32 Console Subsystem

 testet with Windows NT 4.0

 At Startup you get the Focus to the Console!!!!



 implemention now ( *are not in the original Crt-Unit):

 Procedure and Function:

   ClrScr

   ClrEol

   WhereX

   WhereY

   GotoXY

   InsLine

   DelLine

   HighVideo

   LowVideo

   NormVideo

   TextBackground

   TextColor

   Delay // use no processtime

   KeyPressed

   ReadKey // use no processtime

   Sound // with Windows NT your could use the Variables SoundFrequenz, SoundDuration

   NoSound

   *TextAttribut // Set TextBackground and TextColor at the same time, usefull for Lastmode

   *FlushInputBuffer // Flush the Keyboard and all other Events

   *ConsoleEnd // output of 'Press any key' and wait for key input when not pipe

   *Pipe // True when the output is redirected to a pipe or a file



 Variables:

   WindMin // the min. WindowRect

   WindMax // the max. WindowRect

   *ViewMax // the max. ConsoleBuffer start at (1,1);

   TextAttr // Actual Attributes only by changing with this Routines

   LastMode // Last Attributes only by changing with this Routines

   *SoundFrequenz // with Windows NT your could use thise Variables

   *SoundDuration // how long bells the speaker -1 until ??, default = -1

   *HConsoleInput // the Input-handle;

   *HConsoleOutput // the Output-handle;

   *HConsoleError // the Error-handle;





 This Source is freeware, have fun :-)



 History

   23.01.97 Sound, delay, Codepage inserted and setfocus to the console

   24.01.97 Redirected status

}



interface

uses windows,messages;

{$ifdef win32}

const

  Black = 0;

  Blue = 1;

  Green = 2;

  Cyan = 3;

  Red = 4;

  Magenta = 5;

  Brown = 6;

  LightGray = 7;

  DarkGray = 8;

  LightBlue = 9;

  LightGreen = 10;

  LightCyan = 11;

  LightRed = 12;

  LightMagenta = 13;

  Yellow = 14;

  White = 15;



  Function WhereX: integer;

  Function WhereY: integer;

  procedure ClrEol;

  procedure ClrScr;

  procedure InsLine;

  Procedure DelLine;

  Procedure GotoXY(const x,y:integer);

  procedure HighVideo;

  procedure LowVideo;

  procedure NormVideo;

  procedure TextBackground(const Color:word);

  procedure TextColor(const Color:word);

  procedure TextAttribut(const Color,Background:word);

  procedure Delay(const ms:integer);

  function KeyPressed:boolean;

  function ReadKey:Char;

  Procedure Sound;

  Procedure NoSound;

  procedure ConsoleEnd;

  procedure FlushInputBuffer;

  Function Pipe:boolean;



var

  HConsoleInput:thandle;

  HConsoleOutput:thandle;

  HConsoleError:Thandle;

  WindMin:tcoord;

  WindMax:tcoord;

  ViewMax:tcoord;

  TextAttr : Word;

  LastMode : Word;

  SoundFrequenz :Integer;

  SoundDuration : Integer;

{$endif win32}



implementation

_________________ Make file CRT32.pas ________________________________

{$APPTYPE CONSOLE}

unit crt32;

{# freeware}

{# version 1.0.0127}

{# Date 18.01.1997}

{# Author Frank Zimmer}

{# description

 Copyright © 1997, Frank Zimmer, 100703.1602@compuserve.com

 Version: 1.0.0119

 Date: 18.01.1997



 an Implementation of Turbo Pascal CRT-Unit for Win32 Console Subsystem

 testet with Windows NT 4.0

 At Startup you get the Focus to the Console!!!!



 ( with * are not in the original Crt-Unit):

 Procedure and Function:

   ClrScr

   ClrEol

   WhereX

   WhereY

   GotoXY

   InsLine

   DelLine

   HighVideo

   LowVideo

   NormVideo

   TextBackground

   TextColor

   Delay // use no processtime

   KeyPressed

   ReadKey // use no processtime

   Sound // with Windows NT your could use the Variables SoundFrequenz, SoundDuration

   NoSound

   *TextAttribut // Set TextBackground and TextColor at the same time, usefull for Lastmode

   *FlushInputBuffer // Flush the Keyboard and all other Events

   *ConsoleEnd // output of 'Press any key' and wait for key input when not pipe

   *Pipe // True when the output is redirected to a pipe or a file



 Variables:

   WindMin // the min. WindowRect

   WindMax // the max. WindowRect

   *ViewMax // the max. ConsoleBuffer start at (1,1);

   TextAttr // Actual Attributes only by changing with this Routines

   LastMode // Last Attributes only by changing with this Routines

   *SoundFrequenz // with Windows NT your could use these Variables

   *SoundDuration // how long bells the speaker -1 until ??, default = -1

   *HConsoleInput // the Input-handle;

   *HConsoleOutput // the Output-handle;

   *HConsoleError // the Error-handle;





 This Source is freeware, have fun :-)



 History

   18.01.97 the first implementation

   23.01.97 Sound, delay, Codepage inserted and setfocus to the console

   24.01.97 Redirected status

}



interface

uses windows,messages;

{$ifdef win32}

const

  Black = 0;

  Blue = 1;

  Green = 2;

  Cyan = 3;

  Red = 4;

  Magenta = 5;

  Brown = 6;

  LightGray = 7;

  DarkGray = 8;

  LightBlue = 9;

  LightGreen = 10;

  LightCyan = 11;

  LightRed = 12;

  LightMagenta = 13;

  Yellow = 14;

  White = 15;



  Function WhereX: integer;

  Function WhereY: integer;

  procedure ClrEol;

  procedure ClrScr;

  procedure InsLine;

  Procedure DelLine;

  Procedure GotoXY(const x,y:integer);

  procedure HighVideo;

  procedure LowVideo;

  procedure NormVideo;

  procedure TextBackground(const Color:word);

  procedure TextColor(const Color:word);

  procedure TextAttribut(const Color,Background:word);


  procedure Delay(const ms:integer);

  function KeyPressed:boolean;

  function ReadKey:Char;

  Procedure Sound;

  Procedure NoSound;

  procedure ConsoleEnd;

  procedure FlushInputBuffer;

  Function Pipe:boolean;



var

  HConsoleInput:tHandle;

  HConsoleOutput:thandle;

  HConsoleError:Thandle;

  WindMin:tcoord;

  WindMax:tcoord;

  ViewMax:tcoord;

  TextAttr : Word;

  LastMode : Word;

  SoundFrequenz :Integer;

  SoundDuration : Integer;



{$endif win32}



implementation

{$ifdef win32}

uses sysutils;

var

  StartAttr:word;

  OldCP:integer;

  CrtPipe : Boolean;

  German : boolean;



procedure ClrEol;

var tC :tCoord;

  Len,Nw: integer;

  Cbi : TConsoleScreenBufferInfo;

begin

  GetConsoleScreenBufferInfo(HConsoleOutput,cbi);

  len := cbi.dwsize.x-cbi.dwcursorposition.x;

  tc.x := cbi.dwcursorposition.x;

  tc.y := cbi.dwcursorposition.y;

  FillConsoleOutputAttribute(HConsoleOutput,textattr,len,tc,nw);

  FillConsoleOutputCharacter(HConsoleOutput,#32,len,tc,nw);

end;



procedure ClrScr;

var tc :tcoord;

  nw: integer;

  cbi : TConsoleScreenBufferInfo;

begin

  getConsoleScreenBufferInfo(HConsoleOutput,cbi);

  tc.x := 0;

  tc.y := 0;

  FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,tc,nw);

  FillConsoleOutputCharacter(HConsoleOutput,#32,cbi.dwsize.x*cbi.dwsize.y,tc,nw);

  setConsoleCursorPosition(hconsoleoutput,tc);

end;



Function WhereX: integer;

var cbi : TConsoleScreenBufferInfo;

begin

  getConsoleScreenBufferInfo(HConsoleOutput,cbi);

  result := tcoord(cbi.dwCursorPosition).x+1

end;



Function WhereY: integer;

var cbi : TConsoleScreenBufferInfo;

begin

  getConsoleScreenBufferInfo(HConsoleOutput,cbi);

  result := tcoord(cbi.dwCursorPosition).y+1

end;



Procedure GotoXY(const x,y:integer);

var coord :tcoord;

begin

  coord.x := x-1;

  coord.y := y-1;

  setConsoleCursorPosition(hconsoleoutput,coord);

end;



procedure InsLine;

var

 cbi : TConsoleScreenBufferInfo;

 ssr:tsmallrect;

 coord :tcoord;

 ci :tcharinfo;

 nw:integer;

begin

  getConsoleScreenBufferInfo(HConsoleOutput,cbi);

  coord := cbi.dwCursorPosition;

  ssr.left := 0;

  ssr.top := coord.y;

  ssr.right := cbi.srwindow.right;

  ssr.bottom := cbi.srwindow.bottom;

  ci.asciichar := #32;

  ci.attributes := cbi.wattributes;

  coord.x := 0;

  coord.y := coord.y+1;

  ScrollConsoleScreenBuffer(HconsoleOutput,ssr,nil,coord,ci);

  coord.y := coord.y-1;

  FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,coord,nw);

end;



procedure DelLine;

var

 cbi : TConsoleScreenBufferInfo;

 ssr:tsmallrect;

 coord :tcoord;

 ci :tcharinfo;

 nw:integer;

begin

  getConsoleScreenBufferInfo(HConsoleOutput,cbi);

  coord := cbi.dwCursorPosition;

  ssr.left := 0;

  ssr.top := coord.y+1;

  ssr.right := cbi.srwindow.right;

  ssr.bottom := cbi.srwindow.bottom;

  ci.asciichar := #32;

  ci.attributes := cbi.wattributes;

  coord.x := 0;

  coord.y := coord.y;

  ScrollConsoleScreenBuffer(HconsoleOutput,ssr,nil,coord,ci);

  FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,coord,nw);

end;



procedure TextBackground(const Color:word);

begin

  LastMode := TextAttr;

  textattr := (color shl 4) or (textattr and $f);

  SetConsoleTextAttribute(hconsoleoutput,textattr);

end;



procedure TextColor(const Color:word);

begin

  LastMode := TextAttr;

  textattr := (color and $f) or (textattr and $f0);

  SetConsoleTextAttribute(hconsoleoutput,textattr);

end;



procedure TextAttribut(const Color,Background:word);

begin

  LastMode := TextAttr;

  textattr := (color and $f) or (Background shl 4);

  SetConsoleTextAttribute(hconsoleoutput,textattr);

end;



procedure HighVideo;

begin

  LastMode := TextAttr;

  textattr := textattr or $8;

  SetConsoleTextAttribute(hconsoleoutput,textattr);

end;



procedure LowVideo;

begin

  LastMode := TextAttr;

  textattr := textattr and $f7;

  SetConsoleTextAttribute(hconsoleoutput,textattr);

end;



procedure NormVideo;

begin

  LastMode := TextAttr;

  textattr := startAttr;

  SetConsoleTextAttribute(hconsoleoutput,textattr);

end;



procedure FlushInputBuffer;

begin

  FlushConsoleInputBuffer(hconsoleinput)

end;



function keypressed:boolean;

var NumberOfEvents:integer;

begin

  GetNumberOfConsoleInputEvents(hconsoleinput,NumberOfEvents);

  result := NumberOfEvents > 0;

end;



function ReadKey: Char;

var

  NumRead: Integer;

  InputRec: TInputRecord;

begin

  while not ReadConsoleInput(HConsoleInput,

                             InputRec,

                             1,

                             NumRead) or

           (InputRec.EventType <> KEY_EVENT) do;

  Result := InputRec.KeyEvent.AsciiChar

end;



procedure delay(const ms:integer);

begin

  sleep(ms);

end;



Procedure Sound;

begin

  windows.beep(SoundFrequenz,soundduration);

end;



Procedure NoSound;

begin

  windows.beep(soundfrequenz,0);

end;



procedure ConsoleEnd;

begin

  if isconsole and not crtpipe then

  begin

    if wherex > 1 then writeln;

    textcolor(green);

    setfocus(GetCurrentProcess);

    if german then write('Bitte eine Taste drücken!')

              else write('Press any key!');

    normvideo;

    FlushInputBuffer;

    ReadKey;

    FlushInputBuffer;

  end;

end;



function Pipe:boolean;

begin

  result := crtpipe;

end;



procedure init;

var

  cbi : TConsoleScreenBufferInfo;

  tc : tcoord;

begin

 SetActiveWindow(0);

 HConsoleInput := GetStdHandle(STD_InPUT_HANDLE);

 HConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);

 HConsoleError := GetStdHandle(STD_Error_HANDLE);

 if getConsoleScreenBufferInfo(HConsoleOutput,cbi) then

 begin

   TextAttr := cbi.wAttributes;

   StartAttr := cbi.wAttributes;

   lastmode := cbi.wAttributes;

   tc.x := cbi.srwindow.left+1;

   tc.y := cbi.srwindow.top+1;

   windmin := tc;

   ViewMax := cbi.dwsize;

   tc.x := cbi.srwindow.right+1;

   tc.y := cbi.srwindow.bottom+1;

   windmax := tc;

   crtpipe := false;

 end else crtpipe := true;

 SoundFrequenz := 1000;

 SoundDuration := -1;

 oldCp := GetConsoleoutputCP;

 SetConsoleoutputCP(1252);

 german := $07 = (LoWord(GetUserDefaultLangID) and $3ff);

end;



initialization

  init;

finalization

 SetConsoleoutputCP(oldcp);

{$endif win32}

end.

 

Share this article!

Follow us!

Find more helpful articles: