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

Добавить новый Поиск

Eugene - А зачем нужен этот CRT?   2008-07-17 12:02:55 А зачем нужен этот CRT? Цитата 0   0

Snowy   2008-07-17 15:43:47 Для управления возможностями консольных приложений. Цитата 0   0

Валера   2008-09-23 21:39:15 CRT - сила Цитата 0   0

Новичёк   2010-05-28 14:36:49 объясните для дураков с каким расширение сохранять и куда пихать ? Цитата 0   0

Мозг - Неплохо, что есть CRT для Делф   2010-07-12 16:23:39 Правда, не сразу компилируется прога, к которой его подключаешь. В этом коде есть ошибки, но я всё-таки исправил (пришлось закоментировать несколько функций). Цитата 0   0

Я   2010-10-08 08:34:52 Мозг , поставил бы игнор ошибок, и комментировать не пришлось бы) Цитата 0   0

Вот   2010-12-07 21:17:29 У кого получилось все ошибки исправить - может скинуть на мыло (morozgr@gmail.com) Цитата 0   0

комментарии
Имя:
E-mail:	не уведомлятьуведомлять
Заголовок:
UBB-Код:	-цвет-морская волна (aqua)чёрный (black)голубой (blue)фуксия (fuchsia)серый (gray)зелёный (green)лайм (lime)красно-коричневый (maroon)тёмно-синий (navy)оливковый (olive)пурпурный (purple)красный (red)серебрянный (silver)бирюзовый (teal)белый (white)жёлтый (yellow) -размер-крошечный (x-small)маленький (small)средний (medium)большой (large)огромный (x-large)
	Пожалуйста, введите проверочный код, который Вы видите на картинке.