[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    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.

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]