...eine CRT Unit für Delphi nutzen?
Autor: 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;
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.
printed from
www.swissdelphicenter.ch
developers knowledge base