一个CRT Unit

Tags: /超级猛料/Console.控制台程序/ Date Created:

Author: Attila Szomor

{$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 ;

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 ;

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 ;

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;

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 ;

if LineSize <> 0 then

begin

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

end ;

if dwWait > 0 then

begin

NewLine ;

end ;

{$ENDIF}

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 ;

ReadConsoleInput ( hConsoleInput , InputRec , 1 , NumRead );

{$ELSE}

ReadConsoleInput ( hConsoleInput , InputRec , 1 , NumRead );

{$ENDIF}

end ;

Result := Pressed ;

end ;

function ReadKey : char ;

var

NumRead : DWORD ;

InputRec : TInputRecord ;

begin

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 ;

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 ;

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 ;

{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 ;

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 ;

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 ;

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