Windows

Code:

Function ReadComputerName:string;

{©Drkb v.3, ®Vit (Vitaly Nevzorov) }

var

i:DWORD;

p:PChar;

begin

i:=255;

GetMem(p, i);

GetComputerName(p, i);

Result:=String(p);

FreeMem(p);

end;

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

  s: string;

begin

AllocConsole;

try

   Write('Type here your words and press ENTER: ');

   Readln(s);

   ShowMessage(Format('You typed: "%s"', [s]));

finally

   FreeConsole;

end;

end;

Code:

procedure ExecConsoleApp(CommandLine: AnsiString; Output: TStringList; Errors:

TStringList);

var

sa: TSECURITYATTRIBUTES;

si: TSTARTUPINFO;

pi: TPROCESSINFORMATION;

hPipeOutputRead: THANDLE;

hPipeOutputWrite: THANDLE;

hPipeErrorsRead: THANDLE;

hPipeErrorsWrite: THANDLE;

Res, bTest: Boolean;

env: array[0..100] of Char;

szBuffer: array[0..256] of Char;

dwNumberOfBytesRead: DWORD;

Stream: TMemoryStream;

begin

sa.nLength := sizeof(sa);

sa.bInheritHandle := true;

sa.lpSecurityDescriptor := nil;

CreatePipe(hPipeOutputRead, hPipeOutputWrite, @sa, 0);

CreatePipe(hPipeErrorsRead, hPipeErrorsWrite, @sa, 0);

ZeroMemory(@env, SizeOf(env));

ZeroMemory(@si, SizeOf(si));

ZeroMemory(@pi, SizeOf(pi));

si.cb := SizeOf(si);

si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;

si.wShowWindow := SW_HIDE;

si.hStdInput := 0;

si.hStdOutput := hPipeOutputWrite;

si.hStdError := hPipeErrorsWrite;

(* Remember that if you want to execute an app with no parameters you nil the

    second parameter and use the first, you can also leave it as is with no

    problems.                                                                 *)

Res := CreateProcess(nil, pchar(CommandLine), nil, nil, true,

   CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, @env, nil, si, pi);

// Procedure will exit if CreateProcess fail

if not Res then

begin

   CloseHandle(hPipeOutputRead);

   CloseHandle(hPipeOutputWrite);

   CloseHandle(hPipeErrorsRead);

   CloseHandle(hPipeErrorsWrite);

   Exit;

end;

CloseHandle(hPipeOutputWrite);

CloseHandle(hPipeErrorsWrite);

//Read output pipe

Stream := TMemoryStream.Create;

try

   while true do

   begin

     bTest := ReadFile(hPipeOutputRead, szBuffer, 256, dwNumberOfBytesRead,

       nil);

     if not bTest then

     begin

       break;

     end;

     Stream.Write(szBuffer, dwNumberOfBytesRead);

   end;

   Stream.Position := 0;

   Output.LoadFromStream(Stream);

finally

   Stream.Free;

end;

//Read error pipe

Stream := TMemoryStream.Create;

try

   while true do

   begin

     bTest := ReadFile(hPipeErrorsRead, szBuffer, 256, dwNumberOfBytesRead,

       nil);

     if not bTest then

     begin

       break;

     end;

     Stream.Write(szBuffer, dwNumberOfBytesRead);

   end;

   Stream.Position := 0;

   Errors.LoadFromStream(Stream);

finally

   Stream.Free;

end;

WaitForSingleObject(pi.hProcess, INFINITE);

CloseHandle(pi.hProcess);

CloseHandle(hPipeOutputRead);

CloseHandle(hPipeErrorsRead);

end;

(* got it from yahoo groups, so no copyrights for this piece :p and and example

  of how to use it. put a button and a memo to a form.                      *)

procedure TForm1.Button1Click(Sender: TObject);

var

OutP: TStringList;

ErrorP: TStringList;

begin

OutP := TStringList.Create;

ErrorP := TstringList.Create;

ExecConsoleApp('ping localhost', OutP, ErrorP);

Memo1.Lines.Assign(OutP);

OutP.Free;

ErrorP.Free;

end;

Code:

BOOL Ctrl_Handler( DWORD Ctrl )

{

if( (Ctrl == CTRL_SHUTDOWN_EVENT) || (Ctrl == CTRL_LOGOFF_EVENT) )

{

   // Вау! Юзер обламывает!

}

else

{

   // Тут что-от другое можно творить. А можно и не творить :-)

}

return TRUE;

}

Code:

$IfDef VER130}

{$Define NEW_STYLES}

{$EndIf}

{$IfDef VER140}

{$Define NEW_STYLES}

{$EndIf}

{..$Define HARD_CRT}      {Redirect STD_...}

{..$Define CRT_EVENT}     {CTRL-C,...}

{$Define MOUSE_IS_USED}   {Handle mouse or not}

{..$Define OneByOne}      {Block or byte style write}

unit CRT32;

Interface

{$IfDef Win32}

Const

   { CRT modes of original CRT unit }

   BW40 = 0;     { 40x25 B/W on Color Adapter }

   CO40 = 1;     { 40x25 Color on Color Adapter }

   BW80 = 2;     { 80x25 B/W on Color Adapter }

   CO80 = 3;     { 80x25 Color on Color Adapter }

   Mono = 7;     { 80x25 on Monochrome Adapter }

   Font8x8 = 256;{ Add-in for ROM font }

   { Mode constants for 3.0 compatibility of original CRT unit }

   C40 = CO40;

   C80 = CO80;

   { Foreground and background color constants of original CRT unit }

   Black = 0;

   Blue = 1;

   Green = 2;

   Cyan = 3;

   Red = 4;

   Magenta = 5;

   Brown  6;

   LightGray = 7;

   { Foreground color constants of original CRT unit }

   DarkGray = 8;

   LightBlue = 9;

   LightGreen = 10;

   LightCyan = 11;

   LightRed = 12;

   LightMagenta = 13;

   Yellow = 14;

   White = 15;

   { Add-in for blinking of original CRT unit }

   Blink = 128;

   {  }

   {  New constans there are not in original CRT unit }

   {  }

   MouseLeftButton = 1;

   MouseRightButton = 2;

   MouseCenterButton = 4;

var

{ Interface variables of original CRT unit }

CheckBreak: Boolean;    { Enable Ctrl-Break }

CheckEOF: Boolean;      { Enable Ctrl-Z }

DirectVideo: Boolean;   { Enable direct video addressing }

CheckSnow: Boolean;     { Enable snow filtering }

LastMode: Word;         { Current text mode }

TextAttr: Byte;         { Current text attribute }

WindMin: Word;          { Window upper left coordinates }

WindMax: Word;          { Window lower right coordinates }

{  }

{  New variables there are not in original CRT unit }

{  }

MouseInstalled: boolean;

MousePressedButtons: word;

{ Interface functions & procedures of original CRT unit }

procedure AssignCrt(var F: Text);

function KeyPressed: Boolean;

function ReadKey: char;

procedure TextMode(Mode: Integer);

procedure Window(X1, Y1, X2, Y2: Byte);

procedure GotoXY(X, Y: Byte);

function WhereX: Byte;

function WhereY: Byte;

procedure ClrScr;

procedure ClrEol;

procedure InsLine;

procedure DelLine;

procedure TextColor(Color: Byte);

procedure TextBackground(Color: Byte);

procedure LowVideo;

procedure HighVideo;

procedure NormVideo;

procedure Delay(MS: Word);

procedure Sound(Hz: Word);

procedure NoSound;

{ New functions & procedures there are not in original CRT unit }

procedure FillerScreen(FillChar: Char);

procedure FlushInputBuffer;

function GetCursor: Word;

procedure SetCursor(NewCursor: Word);

function MouseKeyPressed: Boolean;

procedure MouseGotoXY(X, Y: Integer);

function MouseWhereY: Integer;

function MouseWhereX: Integer;

procedure MouseShowCursor;

procedure MouseHideCursor;

{ These functions & procedures are for inside use only }

function MouseReset: Boolean;

procedure WriteChrXY(X, Y: Byte; Chr: char);

procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);

procedure OverwriteChrXY(X, Y: Byte; Chr: char);

{$EndIf Win32}

implementation

{$IfDef Win32}

uses Windows, SysUtils;

type

POpenText = ^TOpenText;

TOpenText = function(var F: Text; Mode: Word): Integer; far;

var

IsWinNT: boolean;

PtrOpenText: POpenText;

hConsoleInput: THandle;

hConsoleOutput: THandle;

ConsoleScreenRect: TSmallRect;

StartAttr: word;

LastX, LastY: byte;

SoundDuration: integer;

SoundFrequency: integer;

OldCP: integer;

MouseRowWidth, MouseColWidth: word;

MousePosX, MousePosY: smallInt;

MouseButtonPressed: boolean;

MouseEventTime: TDateTime;

{  }

{  This function handles the Write and WriteLn commands }

{  }

function TextOut(var F: Text): Integer; far;

{$IfDef OneByOne}

var

dwSize: DWORD;

{$EndIf}

begin

with TTExtRec(F) do

begin

   if BufPos > 0 then

   begin

     LastX := WhereX;

     LastY := WhereY;

     {$IfDef OneByOne}

     dwSize := 0;

     while (dwSize < BufPos) do

     begin

       WriteChrXY(LastX, LastY, BufPtr[dwSize]);

       Inc(dwSize);

     end;

     {$Else}

     WriteStrXY(LastX, LastY, BufPtr, BufPos);

     FillChar(BufPtr^, BufPos + 1, #0);

     {$EndIf}

     BufPos := 0;

   end;

end;

Result := 0;

end;

{  }

{  This function handles the exchanging of Input or Output }

{  }

function OpenText(var F: Text; Mode: Word): Integer; far;

var

OpenResult: integer;

begin

OpenResult := 102; { Text not assigned }

if Assigned(PtrOpenText) then

begin

   TTextRec(F).OpenFunc := PtrOpenText;

   OpenResult := PtrOpenText^(F, Mode);

   if OpenResult = 0 then

   begin

     if Mode = fmInput then

       hConsoleInput := TTextRec(F).Handle

     else

     begin

       hConsoleOutput := TTextRec(F).Handle;

       TTextRec(Output).InOutFunc := @TextOut;

       TTextRec(Output).FlushFunc := @TextOut;

     end;

   end;

end;

Result := OpenResult;

end;

{  }

{  Fills the current window with special character }

{  }

procedure FillerScreen(FillChar: Char);

var

Coord: TCoord;

dwSize, dwCount: DWORD;

Y: integer;

begin

Coord.X := ConsoleScreenRect.Left;

dwSize := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;

for Y := ConsoleScreenRect.Top to ConsoleScreenRect.Bottom do

begin

   Coord.Y := Y;

   FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

   FillConsoleOutputCharacter(hConsoleOutput, FillChar, dwSize, Coord, dwCount);

end;

GotoXY(1,1);

end;

{  }

{  Write one character at the X,Y position }

{  }

procedure WriteChrXY(X, Y: Byte; Chr: char);

var

Coord: TCoord;

dwSize, dwCount: DWORD;

begin

LastX := X;

LastY := Y;

case Chr of

   #13: LastX := 1;

   #10:

     begin

       LastX := 1;

       Inc(LastY);

     end;

   else

     begin

       Coord.X := LastX - 1 + ConsoleScreenRect.Left;

       Coord.Y := LastY - 1 + ConsoleScreenRect.Top;

       dwSize := 1;

       FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

       FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);

       Inc(LastX);

     end;

end;

if (LastX + ConsoleScreenRect.Left) > (ConsoleScreenRect.Right + 1) then

begin

   LastX := 1;

   Inc(LastY);

end;

if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then

begin

   Dec(LastY);

   GotoXY(1,1);

   DelLine;

end;

GotoXY(LastX, LastY);

end;

{  }

{  Write string into the X,Y position }

{  }

(* !!! The WriteConsoleOutput does not write into the last line !!!

Procedure WriteStrXY(X,Y: byte; Str: PChar; dwSize: integer );

{$IfDef OneByOne}

   Var

     dwCount: integer;

{$Else}

   Type

     PBuffer= ^TBuffer;

     TBUffer= packed array [0..16384] of TCharInfo;

   Var

     I: integer;

     dwCount: DWORD;

     WidthHeight,Coord: TCoord;

     hTempConsoleOutput: THandle;

     SecurityAttributes: TSecurityAttributes;

     Buffer: PBuffer;

     DestinationScreenRect,SourceScreenRect: TSmallRect;

{$EndIf}

Begin

   If dwSize>0 Then Begin

     {$IfDef OneByOne}

       LastX:=X;

       LastY:=Y;

       dwCount:=0;

       While dwCount < dwSize Do Begin

         WriteChrXY(LastX,LastY,Str[dwCount]);

         Inc(dwCount);

       End;

     {$Else}

       SecurityAttributes.nLength:=SizeOf(SecurityAttributes)-SizeOf(DWORD);

       SecurityAttributes.lpSecurityDescriptor:=NIL;

       SecurityAttributes.bInheritHandle:=TRUE;

       hTempConsoleOutput:=CreateConsoleScreenBuffer(

        GENERIC_READ OR GENERIC_WRITE,

        FILE_SHARE_READ OR FILE_SHARE_WRITE,

        @SecurityAttributes,

        CONSOLE_TEXTMODE_BUFFER,

        NIL

       );

       If dwSize<=(ConsoleScreenRect.Right-ConsoleScreenRect.Left+1) Then Begin

         WidthHeight.X:=dwSize;

         WidthHeight.Y:=1;

       End Else Begin

         WidthHeight.X:=ConsoleScreenRect.Right-ConsoleScreenRect.Left+1;

         WidthHeight.Y:=dwSize DIV WidthHeight.X;

         If (dwSize MOD WidthHeight.X) > 0 Then Inc(WidthHeight.Y);

       End;

       SetConsoleScreenBufferSize(hTempConsoleOutput,WidthHeight);

       DestinationScreenRect.Left:=0;

       DestinationScreenRect.Top:=0;

       DestinationScreenRect.Right:=WidthHeight.X-1;

       DestinationScreenRect.Bottom:=WidthHeight.Y-1;

       SetConsoleWindowInfo(hTempConsoleOutput,FALSE,DestinationScreenRect);

       Coord.X:=0;

       For I:=1 To WidthHeight.Y Do Begin

         Coord.Y:=I-0;

         FillConsoleOutputAttribute(hTempConsoleOutput,TextAttr,WidthHeight.X,Coord,dwCount);

         FillConsoleOutputCharacter(hTempConsoleOutput,' '     ,WidthHeight.X,Coord,dwCount);

       End;

       WriteConsole(hTempConsoleOutput,Str,dwSize,dwCount,NIL);

       {  }

       New(Buffer);

       Coord.X:= 0;

       Coord.Y:= 0;

       SourceScreenRect.Left:=0;

       SourceScreenRect.Top:=0;

       SourceScreenRect.Right:=WidthHeight.X-1;

       SourceScreenRect.Bottom:=WidthHeight.Y-1;

       ReadConsoleOutputA(hTempConsoleOutput,Buffer,WidthHeight,Coord,SourceScreenRect);

       Coord.X:=X-1;

       Coord.Y:=Y-1;

       DestinationScreenRect:=ConsoleScreenRect;

       WriteConsoleOutputA(hConsoleOutput,Buffer,WidthHeight,Coord,DestinationScreenRect);

       GotoXY((dwSize MOD WidthHeight.X)-1,WidthHeight.Y+1);

       Dispose(Buffer);

       {  }

       CloseHandle(hTempConsoleOutput);

     {$EndIf}

   End;

End;

*)

procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);

{$IfDef OneByOne}

var

dwCount: integer;

{$Else}

var

I: integer;

LineSize, dwCharCount, dwCount, dwWait: DWORD;

WidthHeight: TCoord;

OneLine: packed array [0..131] of char;

Line, TempStr: PChar;

procedure NewLine;

begin

   LastX := 1;

   Inc(LastY);

   if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then

   begin

     Dec(LastY);

     GotoXY(1,1);

     DelLine;

   end;

   GotoXY(LastX, LastY);

end;

{$EndIf}

begin

if dwSize > 0 then

begin

   {$IfDef OneByOne}

   LastX := X;

   LastY := Y;

   dwCount := 0;

   while dwCount < dwSize do

   begin

     WriteChrXY(LastX, LastY, Str[dwCount]);

     Inc(dwCount);

   end;

   {$Else}

   LastX := X;

   LastY := Y;

   GotoXY(LastX, LastY);

   dwWait  := dwSize;

   TempStr := Str;

   while (dwWait > 0) and (Pos(#13#10, StrPas(TempStr)) = 1) do

   begin

     Dec(dwWait, 2);

     Inc(TempStr, 2);

     NewLine;

   end;

   while (dwWait > 0) and (Pos(#10, StrPas(TempStr)) = 1) do

   begin

     Dec(dwWait);

     Inc(TempStr);

     NewLine;

   end;

   if dwWait > 0 then

   begin

     if dwSize <= (ConsoleScreenRect.Right - ConsoleScreenRect.Left - LastX + 1) then

     begin

       WidthHeight.X := dwSize + LastX - 1;

       WidthHeight.Y := 1;

     end

     else

     begin

       WidthHeight.X := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;

       WidthHeight.Y := dwSize div WidthHeight.X;

       if (dwSize mod WidthHeight.X) > 0 then Inc(WidthHeight.Y);

     end;

     for I := 1 to WidthHeight.Y do

     begin

       FillChar(OneLine, SizeOf(OneLine), #0);

       Line := @OneLine;

       LineSize := WidthHeight.X - LastX + 1;

       if LineSize > dwWait then LineSize := dwWait;

       Dec(dwWait, LineSize);

       StrLCopy(Line, TempStr, LineSize);

       Inc(TempStr, LineSize);

       dwCharCount := Pos(#13#10, StrPas(Line));

       if dwCharCount > 0 then

       begin

         OneLine[dwCharCount - 1] := #0;

         OneLine[dwCharCount]     := #0;

         WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);

         Inc(Line, dwCharCount + 1);

         NewLine;

         LineSize := LineSize - (dwCharCount + 1);

       end

       else

       begin

         dwCharCount := Pos(#10, StrPas(Line));

         if dwCharCount > 0 then

         begin

           OneLine[dwCharCount - 1] := #0;

           WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);

           Inc(Line, dwCharCount);

           NewLine;

           LineSize := LineSize - dwCharCount;

         end;

       end;

       if LineSize <> 0 then

       begin

         WriteConsole(hConsoleOutput, Line, LineSize, dwCount, nil);

       end;

       if dwWait > 0 then

       begin

         NewLine;

       end;

     end;

   end;

   {$EndIf}

end;

end;

{  }

{  Empty the buffer }

{  }

procedure FlushInputBuffer;

begin

FlushConsoleInputBuffer(hConsoleInput);

end;

{  }

{  Get size of current cursor }

{  }

function GetCursor: Word;

var

CCI: TConsoleCursorInfo;

begin

GetConsoleCursorInfo(hConsoleOutput, CCI);

GetCursor := CCI.dwSize;

end;

{  }

{  Set size of current cursor }

{  }

procedure SetCursor(NewCursor: Word);

var

CCI: TConsoleCursorInfo;

begin

if NewCursor = $0000 then

begin

   CCI.dwSize := GetCursor;

   CCI.bVisible := False;

end

else

begin

   CCI.dwSize := NewCursor;

   CCI.bVisible := True;

end;

SetConsoleCursorInfo(hConsoleOutput, CCI);

end;

{  }

{ --- Begin of Interface functions & procedures of original CRT unit --- }

procedure AssignCrt(var F: Text);

begin

Assign(F, '');

TTextRec(F).OpenFunc := @OpenText;

end;

function KeyPressed: Boolean;

var

NumberOfEvents: DWORD;

NumRead: DWORD;

InputRec: TInputRecord;

Pressed: boolean;

begin

Pressed := False;

GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents);

if NumberOfEvents > 0 then

begin

   if PeekConsoleInput(hConsoleInput, InputRec, 1,NumRead) then

   begin

     if (InputRec.EventType = KEY_EVENT) and

       (InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.bKeyDown) then

     begin

       Pressed := True;

       {$IfDef MOUSE_IS_USED}

       MouseButtonPressed := False;

       {$EndIf}

     end

     else

     begin

       {$IfDef MOUSE_IS_USED}

       if (InputRec.EventType = _MOUSE_EVENT) then

       begin

         with InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.MouseEvent do

         begin

           MousePosX := dwMousePosition.X;

           MousePosY := dwMousePosition.Y;

           if dwButtonState = FROM_LEFT_1ST_BUTTON_PRESSED then

           begin

             MouseEventTime := Now;

             MouseButtonPressed := True;

             {If (dwEventFlags AND DOUBLE_CLICK)<>0 Then Begin}

             {End;}

           end;

         end;

       end;

       ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);

       {$Else}

       ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);

       {$EndIf}

     end;

   end;

end;

Result := Pressed;

end;

function ReadKey: char;

var

NumRead: DWORD;

InputRec: TInputRecord;

begin

repeat

   repeat

   until KeyPressed;

   ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);

until InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar > #0;

Result := InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar;

end;

procedure TextMode(Mode: Integer);

begin

end;

procedure Window(X1, Y1, X2, Y2: Byte);

begin

ConsoleScreenRect.Left := X1 - 1;

ConsoleScreenRect.Top := Y1 - 1;

ConsoleScreenRect.Right := X2 - 1;

ConsoleScreenRect.Bottom := Y2 - 1;

WindMin := (ConsoleScreenRect.Top shl 8) or ConsoleScreenRect.Left;

WindMax := (ConsoleScreenRect.Bottom shl 8) or ConsoleScreenRect.Right;

{$IfDef WindowFrameToo}

SetConsoleWindowInfo(hConsoleOutput, True, ConsoleScreenRect);

{$EndIf}

GotoXY(1,1);

end;

procedure GotoXY(X, Y: Byte);

var

Coord: TCoord;

begin

Coord.X := X - 1 + ConsoleScreenRect.Left;

Coord.Y := Y - 1 + ConsoleScreenRect.Top;

if not SetConsoleCursorPosition(hConsoleOutput, Coord) then

begin

   GotoXY(1, 1);

   DelLine;

end;

end;

function WhereX: Byte;

var

CBI: TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(hConsoleOutput, CBI);

Result := TCoord(CBI.dwCursorPosition).X + 1 - ConsoleScreenRect.Left;

end;

function WhereY: Byte;

var

CBI: TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(hConsoleOutput, CBI);

Result := TCoord(CBI.dwCursorPosition).Y + 1 - ConsoleScreenRect.Top;

end;

procedure ClrScr;

begin

FillerScreen(' ');

end;

procedure ClrEol;

var

Coord: TCoord;

dwSize, dwCount: DWORD;

begin

Coord.X := WhereX - 1 + ConsoleScreenRect.Left;

Coord.Y := WhereY - 1 + ConsoleScreenRect.Top;

dwSize  := ConsoleScreenRect.Right - Coord.X + 1;

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

FillConsoleOutputCharacter(hConsoleOutput, ' ', dwSize, Coord, dwCount);

end;

procedure InsLine;

var

SourceScreenRect: TSmallRect;

Coord: TCoord;

CI: TCharInfo;

dwSize, dwCount: DWORD;

begin

SourceScreenRect := ConsoleScreenRect;

SourceScreenRect.Top := WhereY - 1 + ConsoleScreenRect.Top;

SourceScreenRect.Bottom := ConsoleScreenRect.Bottom - 1;

CI.AsciiChar := ' ';

CI.Attributes := TextAttr;

Coord.X := SourceScreenRect.Left;

Coord.Y := SourceScreenRect.Top + 1;

dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;

ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);

Dec(Coord.Y);

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

end;

procedure DelLine;

var

SourceScreenRect: TSmallRect;

Coord: TCoord;

CI: TCharinfo;

dwSize, dwCount: DWORD;

begin

SourceScreenRect := ConsoleScreenRect;

SourceScreenRect.Top := WhereY + ConsoleScreenRect.Top;

CI.AsciiChar := ' ';

CI.Attributes := TextAttr;

Coord.X := SourceScreenRect.Left;

Coord.Y := SourceScreenRect.Top - 1;

dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;

ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

end;

procedure TextColor(Color: Byte);

begin

LastMode := TextAttr;

TextAttr := (Color and $0F) or (TextAttr and $F0);

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure TextBackground(Color: Byte);

begin

LastMode := TextAttr;

TextAttr := (Color shl 4) or (TextAttr and $0F);

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure LowVideo;

begin

LastMode := TextAttr;

TextAttr := TextAttr and $F7;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure HighVideo;

begin

LastMode := TextAttr;

TextAttr := TextAttr or $08;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure NormVideo;

begin

LastMode := TextAttr;

TextAttr := StartAttr;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure Delay(MS: Word);

{

Const

   Magic= $80000000;

var

  StartMS,CurMS,DeltaMS: DWORD;

  }

begin

Windows.SleepEx(MS, False);  // Windows.Sleep(MS);

   {

   StartMS:= GetTickCount;

   Repeat

     CurMS:= GetTickCount;

     If CurMS >= StartMS Then

        DeltaMS:= CurMS - StartMS

     Else DeltaMS := (CurMS + Magic) - (StartMS - Magic);

   Until MS<DeltaMS;

   }

end;

procedure Sound(Hz: Word);

begin

{SetSoundIOPermissionMap(LocalIOPermission_ON);}

SoundFrequency := Hz;

if IsWinNT then

begin

   Windows.Beep(SoundFrequency, SoundDuration)

end

else

begin

   asm

       mov  BX,Hz

       cmp  BX,0

       jz   @2

       mov  AX,$34DD

       mov  DX,$0012

       cmp  DX,BX

       jnb  @2

       div BX

       mov  BX,AX

       { Sound is On ? }

       in   Al,$61

       test Al,$03

       jnz  @1

       { Set Sound On }

       or   Al,03

       out $61,Al

       { Timer Command }

       mov  Al,$B6

       out $43,Al

       { Set Frequency }

   @1: mov  Al,Bl

       out $42,Al

       mov  Al,Bh

       out $42,Al

   @2:

   end;

end;

end;

procedure NoSound;

begin

if IsWinNT then

begin

   Windows.Beep(SoundFrequency, 0);

end

else

begin

     asm

       { Set Sound On }

       in   Al,$61

       and Al,$FC

       out $61,Al

     end;

end;

{SetSoundIOPermissionMap(LocalIOPermission_OFF);}

end;

{ --- End of Interface functions & procedures of original CRT unit --- }

{  }

procedure OverwriteChrXY(X, Y: Byte; Chr: char);

var

Coord: TCoord;

dwSize, dwCount: DWORD;

begin

LastX := X;

LastY := Y;

Coord.X := LastX - 1 + ConsoleScreenRect.Left;

Coord.Y := LastY - 1 + ConsoleScreenRect.Top;

dwSize := 1;

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);

GotoXY(LastX, LastY);

end;

{  --------------------------------------------------  }

{  Console Event Handler }

{  }

{$IfDef CRT_EVENT}

function ConsoleEventProc(CtrlType: DWORD): Bool; stdcall; far;

var

S: {$IfDef Win32}ShortString{$Else}String{$EndIf};

Message: PChar;

begin

case CtrlType of

   CTRL_C_EVENT: S        := 'CTRL_C_EVENT';

   CTRL_BREAK_EVENT: S    := 'CTRL_BREAK_EVENT';

   CTRL_CLOSE_EVENT: S    := 'CTRL_CLOSE_EVENT';

   CTRL_LOGOFF_EVENT: S   := 'CTRL_LOGOFF_EVENT';

   CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';

   else

     S := 'UNKNOWN_EVENT';

end;

S := S + ' detected, but not handled.';

Message := @S;

Inc(Message);

MessageBox(0, Message, 'Win32 Console', MB_OK);

Result := True;

end;

{$EndIf}

function MouseReset: Boolean;

begin

MouseColWidth := 1;

MouseRowWidth := 1;

Result := True;

end;

procedure MouseShowCursor;

const

ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;

var

cMode: DWORD;

begin

GetConsoleMode(hConsoleInput, cMode);

if (cMode and ShowMouseConsoleMode) <> ShowMouseConsoleMode then

begin

   cMode := cMode or ShowMouseConsoleMode;

   SetConsoleMode(hConsoleInput, cMode);

end;

end;

procedure MouseHideCursor;

const

ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;

var

cMode: DWORD;

begin

GetConsoleMode(hConsoleInput, cMode);

if (cMode and ShowMouseConsoleMode) = ShowMouseConsoleMode then

begin

   cMode := cMode and ($FFFFFFFF xor ShowMouseConsoleMode);

   SetConsoleMode(hConsoleInput, cMode);

end;

end;

function MouseKeyPressed: Boolean;

{$IfDef MOUSE_IS_USED}

const

MouseDeltaTime = 200;

var

ActualTime: TDateTime;

HourA, HourM, MinA, MinM, SecA, SecM, MSecA, MSecM: word;

MSecTimeA, MSecTimeM: longInt;

MSecDelta: longInt;

{$EndIf}

begin

MousePressedButtons := 0;

{$IfDef MOUSE_IS_USED}

Result := False;

if MouseButtonPressed then

begin

   ActualTime := NOW;

   DecodeTime(ActualTime, HourA, MinA, SecA, MSecA);

   DecodeTime(MouseEventTime, HourM, MinM, SecM, MSecM);

   MSecTimeA := (3600 * HourA + 60 * MinA + SecA) * 100 + MSecA;

   MSecTimeM := (3600 * HourM + 60 * MinM + SecM) * 100 + MSecM;

   MSecDelta := Abs(MSecTimeM - MSecTimeA);

   if (MSecDelta < MouseDeltaTime) or (MSecDelta > (8784000 - MouseDeltaTime)) then

   begin

     MousePressedButtons := MouseLeftButton;

     MouseButtonPressed := False;

     Result := True;

   end;

end;

{$Else}

Result := False;

{$EndIf}

end;

procedure MouseGotoXY(X, Y: Integer);

begin

{$IfDef MOUSE_IS_USED}

mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE,

   X - 1,Y - 1,WHEEL_DELTA, GetMessageExtraInfo());

MousePosY := (Y - 1) * MouseRowWidth;

MousePosX := (X - 1) * MouseColWidth;

{$EndIf}

end;

function MouseWhereY: Integer;

{$IfDef MOUSE_IS_USED}

   {Var

     lppt, lpptBuf: TMouseMovePoint;}

{$EndIf}

begin

{$IfDef MOUSE_IS_USED}

     {GetMouseMovePoints(

       SizeOf(TMouseMovePoint), lppt, lpptBuf,

       7,GMMP_USE_DRIVER_POINTS

     );

     Result:=lpptBuf.Y DIV MouseRowWidth;}

Result := (MousePosY div MouseRowWidth) + 1;

{$Else}

Result := -1;

{$EndIf}

end;

function MouseWhereX: Integer;

{$IfDef MOUSE_IS_USED}

   {Var

     lppt, lpptBuf: TMouseMovePoint;}

{$EndIf}

begin

{$IfDef MOUSE_IS_USED}

     {GetMouseMovePoints(

       SizeOf(TMouseMovePoint), lppt, lpptBuf,

       7,GMMP_USE_DRIVER_POINTS

     );

     Result:=lpptBuf.X DIV MouseColWidth;}

Result := (MousePosX div MouseColWidth) + 1;

{$Else}

Result := -1;

{$EndIf}

end;

{  }

procedure Init;

const

ExtInpConsoleMode = ENABLE_WINDOW_INPUT or ENABLE_PROCESSED_INPUT or ENABLE_MOUSE_INPUT;

ExtOutConsoleMode = ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT;

var

cMode: DWORD;

Coord: TCoord;

OSVersion: TOSVersionInfo;

CBI: TConsoleScreenBufferInfo;

begin

OSVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);

GetVersionEx(OSVersion);

if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then

   IsWinNT := True

else

   IsWinNT := False;

PtrOpenText := TTextRec(Output).OpenFunc;

{$IfDef HARD_CRT}

AllocConsole;

Reset(Input);

hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);

TTextRec(Input).Handle := hConsoleInput;

ReWrite(Output);

hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);

TTextRec(Output).Handle := hConsoleOutput;

{$Else}

Reset(Input);

hConsoleInput := TTextRec(Input).Handle;

ReWrite(Output);

hConsoleOutput := TTextRec(Output).Handle;

{$EndIf}

GetConsoleMode(hConsoleInput, cMode);

if (cMode and ExtInpConsoleMode) <> ExtInpConsoleMode then

begin

   cMode := cMode or ExtInpConsoleMode;

   SetConsoleMode(hConsoleInput, cMode);

end;

TTextRec(Output).InOutFunc := @TextOut;

TTextRec(Output).FlushFunc := @TextOut;

GetConsoleScreenBufferInfo(hConsoleOutput, CBI);

GetConsoleMode(hConsoleOutput, cMode);

if (cMode and ExtOutConsoleMode) <> ExtOutConsoleMode then

begin

   cMode := cMode or ExtOutConsoleMode;

   SetConsoleMode(hConsoleOutput, cMode);

end;

TextAttr  := CBI.wAttributes;

StartAttr := CBI.wAttributes;

LastMode  := CBI.wAttributes;

Coord.X := CBI.srWindow.Left;

Coord.Y := CBI.srWindow.Top;

WindMin := (Coord.Y shl 8) or Coord.X;

Coord.X := CBI.srWindow.Right;

Coord.Y := CBI.srWindow.Bottom;

WindMax := (Coord.Y shl 8) or Coord.X;

ConsoleScreenRect := CBI.srWindow;

SoundDuration := -1;

OldCp := GetConsoleOutputCP;

SetConsoleOutputCP(1250);

{$IfDef CRT_EVENT}

SetConsoleCtrlHandler(@ConsoleEventProc, True);

{$EndIf}

{$IfDef MOUSE_IS_USED}

SetCapture(hConsoleInput);

KeyPressed;

{$EndIf}

MouseInstalled := MouseReset;

Window(1,1,80,25);

ClrScr;

end;

{  }

procedure Done;

begin

{$IfDef CRT_EVENT}

SetConsoleCtrlHandler(@ConsoleEventProc, False);

{$EndIf}

SetConsoleOutputCP(OldCP);

TextAttr := StartAttr;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

ClrScr;

FlushInputBuffer;

{$IfDef HARD_CRT}

TTextRec(Input).Mode := fmClosed;

TTextRec(Output).Mode := fmClosed;

FreeConsole;

{$Else}

Close(Input);

Close(Output);

{$EndIf}

end;

initialization

Init;

finalization

Done;

{$Endif win32}

end.