Crt от FreePascal для Delphi

[Mortem]

Есть ли сабж? А то я консольную прогу на FP написал. Теперь вот хочу на Delphi это дело откомпилить эксперименту ради... (:

[haword]

Есть ли сабж? А то я консольную прогу на FP написал. Теперь вот хочу на Delphi это дело откомпилить эксперименту ради... (:

<a href='http://www.torry.net/pages.php?id=236' target='_blank'>http://www.torry.net/pages.php?id=236</a>
воть тебе для счастья

[Оззя]

Взято с ДРКБ

Код: Выделить всё

CRT для консольного приложения


     
 

$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.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

[Mortem]

Спасибо. Модуль собрал, откомпилил даже всё. Прога получилась в ~6 раз меньше по размеру. Но при этом страшно глючит и иногда вылетает нафиг. (:
В целом миссию свою я выполнил. Продолжу кодимть на FP. (: