123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986 |
- {
- $Id$
- Borland Pascal 7 Compatible CRT Unit for win32
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- unit crt;
- {$mode objfpc}
- interface
- const
- { CRT modes }
- 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 }
- C40 = CO40;
- C80 = CO80;
- { Foreground and background color constants }
- Black = 0;
- Blue = 1;
- Green = 2;
- Cyan = 3;
- Red = 4;
- Magenta = 5;
- Brown = 6;
- LightGray = 7;
- { Foreground color constants }
- DarkGray = 8;
- LightBlue = 9;
- LightGreen = 10;
- LightCyan = 11;
- LightRed = 12;
- LightMagenta = 13;
- Yellow = 14;
- White = 15;
- { Add-in for blinking }
- Blink = 128;
- var
- { Interface variables }
- 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 }
- { Interface procedures }
- 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;
- {Extra Functions}
- procedure cursoron;
- procedure cursoroff;
- procedure cursorbig;
- implementation
- uses
- dos,
- windows;
- var
- OutHandle : THandle;
- InputHandle : THandle;
- CursorSaveX : Longint;
- CursorSaveY : Longint;
- ScreenWidth : Longint;
- ScreenHeight : Longint;
- IsWindowsNT : Boolean;
- SaveCursorSize: Longint;
- {
- definition of textrec is in textrec.inc
- }
- {$i textrec.inc}
- {****************************************************************************
- Low level Routines
- ****************************************************************************}
- function GetPlatformID: Longint;
- var OsVersion: TOSVersionInfo;
- begin
- OsVersion.dwOsVersionInfoSize := SizeOf(OsVersion);
- GetVersionEx(OsVersion);
- Result := OsVersion.dwPlatformID;
- end; { func. GetPlatformID }
- procedure TurnMouseOff;
- var Mode: DWORD;
- begin
- if GetConsoleMode(InputHandle, @Mode) then { Turn the mouse-cursor off }
- begin
- Mode := Mode AND NOT enable_processed_input
- AND NOT enable_mouse_input;
- SetConsoleMode(InputHandle, Mode);
- end; { if }
- end; { proc. TurnMouseOff }
- function GetScreenHeight : longint;
- var ConsoleInfo: TConsoleScreenBufferinfo;
- begin
- GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
- Result := ConsoleInfo.dwSize.Y;
- end; { func. GetScreenHeight }
- function GetScreenWidth : longint;
- var ConsoleInfo: TConsoleScreenBufferInfo;
- begin
- GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
- Result := ConsoleInfo.dwSize.X;
- end; { func. GetScreenWidth }
- procedure SetScreenCursor(x,y : longint);
- var CurInfo: TCoord;
- begin
- FillChar(Curinfo, SizeOf(Curinfo), 0);
- CurInfo.X := X - 1;
- CurInfo.Y := Y - 1;
- SetConsoleCursorPosition(OutHandle, CurInfo);
- CursorSaveX := X - 1;
- CursorSaveY := Y - 1;
- end;
- procedure GetScreenCursor(var x,y : longint);
- begin
- X := CursorSaveX + 1;
- Y := CursorSaveY + 1;
- end;
- {****************************************************************************
- Helper Routines
- ****************************************************************************}
- Function WinMinX: Byte;
- {
- Current Minimum X coordinate
- }
- Begin
- WinMinX:=(WindMin and $ff)+1;
- End;
- Function WinMinY: Byte;
- {
- Current Minimum Y Coordinate
- }
- Begin
- WinMinY:=(WindMin shr 8)+1;
- End;
- Function WinMaxX: Byte;
- {
- Current Maximum X coordinate
- }
- Begin
- WinMaxX:=(WindMax and $ff)+1;
- End;
- Function WinMaxY: Byte;
- {
- Current Maximum Y coordinate;
- }
- Begin
- WinMaxY:=(WindMax shr 8) + 1;
- End;
- Function FullWin:boolean;
- {
- Full Screen 80x25? Window(1,1,80,25) is used, allows faster routines
- }
- begin
- FullWin:=(WinMinX=1) and (WinMinY=1) and
- (WinMaxX=ScreenWidth) and (WinMaxY=ScreenHeight);
- end;
- {****************************************************************************
- Public Crt Functions
- ****************************************************************************}
- procedure textmode(mode : integer);
- begin
- {!!! Not done yet !!! }
- end;
- Procedure TextColor(Color: Byte);
- {
- Switch foregroundcolor
- }
- Begin
- TextAttr:=(Color and $8f) or (TextAttr and $70);
- End;
- Procedure TextBackground(Color: Byte);
- {
- Switch backgroundcolor
- }
- Begin
- TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) );
- End;
- Procedure HighVideo;
- {
- Set highlighted output.
- }
- Begin
- TextColor(TextAttr Or $08);
- End;
- Procedure LowVideo;
- {
- Set normal output
- }
- Begin
- TextColor(TextAttr And $77);
- End;
- Procedure NormVideo;
- {
- Set normal back and foregroundcolors.
- }
- Begin
- TextColor(7);
- TextBackGround(0);
- End;
- Procedure GotoXy(X: Byte; Y: Byte);
- {
- Go to coordinates X,Y in the current window.
- }
- Begin
- If (X>0) and (X<=WinMaxX- WinMinX+1) and
- (Y>0) and (Y<=WinMaxY-WinMinY+1) Then
- Begin
- Inc(X,WinMinX-1);
- Inc(Y,WinMinY-1);
- SetScreenCursor(x,y);
- End;
- End;
- Procedure Window(X1, Y1, X2, Y2: Byte);
- {
- Set screen window to the specified coordinates.
- }
- Begin
- if (X1>X2) or (X2>ScreenWidth) or
- (Y1>Y2) or (Y2>ScreenHeight) then
- exit;
- WindMin:=((Y1-1) Shl 8)+(X1-1);
- WindMax:=((Y2-1) Shl 8)+(X2-1);
- GoToXY(1,1);
- End;
- procedure ClrScr;
- var
- ClipRect: TSmallRect;
- SrcRect: TSmallRect;
- DestCoor: TCoord;
- CharInfo: TCharInfo;
- begin
- CharInfo.UnicodeChar := 32;
- CharInfo.Attributes := TextAttr;
- SrcRect.Left := WinMinX - 1;
- SrcRect.Top := WinMinY - 1;
- SrcRect.Right := WinMaxX - 1;
- SrcRect.Bottom := WinMaxY - 1;
- ClipRect := SrcRect;
- if IsWindowsNT then
- begin
- DestCoor.X := -WinMaxX;
- DestCoor.Y := -WinMaxY;
- ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
- DestCoor, CharInfo);
- end
- else begin { Win95 seems to have a bug in scrolling, unfortunately }
- { This routine 3 times copies the bottom 12 lines to the }
- { top part of the screen. This eventually will clear the }
- { screen. }
- DestCoor.X := WinMinX - 1;
- DestCoor.Y := WinMinY - (Succ((WinMaxY - WinMinY) div 2));
- {-------- Scroll 1st part }
- ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
- DestCoor, CharInfo);
- {-------- Scroll 2nd part }
- ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
- DestCoor, CharInfo);
- {-------- Scroll 3rd part (last line) }
- ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
- DestCoor, CharInfo);
- end; { if in Windows95 }
- GotoXY(1,1);
- end; { proc. ClrScr }
- procedure ClrEol;
- {
- Clear from current position to end of line.
- }
- var Temp: Dword;
- CharInfo: Char;
- Coord: TCoord;
- X,Y: Longint;
- begin
- GetScreenCursor(x,y);
- CharInfo := #32;
- Coord.X := X - 1;
- Coord.Y := Y - 1;
- FillConsoleOutputCharacter(OutHandle, CharInfo, WinMaxX - (X + 01), Coord, @Temp);
- end;
- Function WhereX: Byte;
- {
- Return current X-position of cursor.
- }
- var
- x,y : longint;
- Begin
- GetScreenCursor(x,y);
- WhereX:=x-WinMinX+1;
- End;
- Function WhereY: Byte;
- {
- Return current Y-position of cursor.
- }
- var
- x,y : longint;
- Begin
- GetScreenCursor(x,y);
- WhereY:=y-WinMinY+1;
- End;
- {*************************************************************************
- KeyBoard
- *************************************************************************}
- var
- ScanCode : char;
- SpecialKey : boolean;
- DoingNumChars: Boolean;
- DoingNumCode: Byte;
- Function RemapScanCode (ScanCode: byte; CtrlKeyState: byte; keycode:longint): byte;
- { Several remappings of scancodes are necessary to comply with what
- we get with MSDOS. Special Windows keys, as Alt-Tab, Ctrl-Esc etc.
- are excluded }
- var
- AltKey, CtrlKey, ShiftKey: boolean;
- const
- {
- Keypad key scancodes:
- Ctrl Norm
- $77 $47 - Home
- $8D $48 - Up arrow
- $84 $49 - PgUp
- $8E $4A - -
- $73 $4B - Left Arrow
- $8F $4C - 5
- $74 $4D - Right arrow
- $4E $4E - +
- $75 $4F - End
- $91 $50 - Down arrow
- $76 $51 - PgDn
- $92 $52 - Ins
- $93 $53 - Del
- }
- CtrlKeypadKeys: array[$47..$53] of byte =
- ($77, $8D, $84, $8E, $73, $8F, $74, $4E, $75, $91, $76, $92, $93);
- begin
- AltKey := ((CtrlKeyState AND
- (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
- CtrlKey := ((CtrlKeyState AND
- (RIGHT_CTRL_PRESSED OR LEFT_CTRL_PRESSED)) > 0);
- ShiftKey := ((CtrlKeyState AND SHIFT_PRESSED) > 0);
- if AltKey then begin
- Case KeyCode of
- VK_NUMPAD0 ..
- VK_NUMPAD9 : begin
- DoingNumChars := true;
- DoingNumCode := Byte((DoingNumCode * 10) + (KeyCode - VK_NUMPAD0));
- end;
- end; { case }
- case ScanCode of
- // Digits, -, =
- $02..$0D: inc(ScanCode, $76);
- // Function keys
- $3B..$44: inc(Scancode, $2D);
- $57..$58: inc(Scancode, $34);
- // Extended cursor block keys
- $47..$49, $4B, $4D, $4F..$53:
- inc(Scancode, $50);
- // Other keys
- $1C: Scancode := $A6; // Enter
- $35: Scancode := $A4; // / (keypad and normal!)
- end
- end
- else if CtrlKey then
- case Scancode of
- // Tab key
- $0F: Scancode := $94;
- // Function keys
- $3B..$44: inc(Scancode, $23);
- $57..$58: inc(Scancode, $32);
- // Keypad keys
- $35: Scancode := $95; // \
- $37: Scancode := $96; // *
- $47..$53: Scancode := CtrlKeypadKeys[Scancode];
- end
- else if ShiftKey then
- case Scancode of
- // Function keys
- $3B..$44: inc(Scancode, $19);
- $57..$58: inc(Scancode, $30);
- end
- else
- case Scancode of
- // Function keys
- $57..$58: inc(Scancode, $2E); // F11 and F12
- end;
- Result := ScanCode;
- end;
- function KeyPressed : boolean;
- var
- nevents, nread, i: longint;
- buf : TINPUTRECORD;
- AltKey: Boolean;
- begin
- KeyPressed := FALSE;
- if ScanCode <> #0 then
- KeyPressed := TRUE
- else
- begin
- nevents:=0;
- GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents);
- For i := 1 to nevents do
- begin
- ReadConsoleInputA(TextRec(input).Handle,buf,1,nread);
- if buf.EventType = KEY_EVENT then
- if buf.KeyEvent.bKeyDown then
- begin
- { Alt key is VK_MENU }
- { Capslock key is VK_CAPITAL }
- AltKey := ((Buf.KeyEvent.dwControlKeyState AND
- (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
- if (Buf.KeyEvent.wVirtualKeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL,
- VK_CAPITAL, VK_NUMLOCK,
- VK_SCROLL]) then
- begin
- { Discard this key }
- end
- else begin
- KeyPressed := TRUE;
- if ord(buf.KeyEvent.AsciiChar) = 0 then
- begin
- SpecialKey := TRUE;
- ScanCode := Chr(RemapScanCode(Buf.KeyEvent.wVirtualScanCode, Buf.KeyEvent.dwControlKeyState,
- Buf.KeyEvent.wVirtualKeyCode));
- end
- else
- begin
- SpecialKey := FALSE;
- ScanCode := Chr(Ord(buf.KeyEvent.AsciiChar));
- end;
- if Buf.KeyEvent.wVirtualKeyCode in [VK_NUMPAD0..VK_NUMPAD9] then
- if AltKey then
- begin
- Keypressed := false;
- Specialkey := false;
- ScanCode := #0;
- end
- else BREAK;
- end;
- end { if }
- else if (Buf.KeyEvent.wVirtualKeyCode in [VK_MENU]) then
- if DoingNumChars then
- if DoingNumCode > 0 then
- begin
- ScanCode := Chr(DoingNumCode);
- Keypressed := true;
- DoingNumChars := false;
- DoingNumCode := 0;
- BREAK;
- end; { if }
- end;
- end;
- end;
- function ReadKey: char;
- begin
- repeat
- Sleep(1);
- until KeyPressed;
- if SpecialKey then begin
- ReadKey := #0;
- SpecialKey := FALSE;
- end
- else begin
- ReadKey := ScanCode;
- ScanCode := #0;
- end;
- end;
- {*************************************************************************
- Delay
- *************************************************************************}
- procedure Delay(MS: Word);
- begin
- Sleep(ms);
- end; { proc. Delay }
- procedure sound(hz : word);
- begin
- MessageBeep(0); { lame ;-) }
- end;
- procedure nosound;
- begin
- end;
- {****************************************************************************
- HighLevel Crt Functions
- ****************************************************************************}
- procedure removeline(y : longint);
- var
- ClipRect: TSmallRect;
- SrcRect: TSmallRect;
- DestCoor: TCoord;
- CharInfo: TCharInfo;
- begin
- CharInfo.UnicodeChar := 32;
- CharInfo.Attributes := TextAttr;
- Y := WinMinY + Y-1;
- SrcRect.Top := Y - 01;
- SrcRect.Left := WinMinX - 1;
- SrcRect.Right := WinMaxX - 1;
- SrcRect.Bottom := WinMaxY - 1;
- DestCoor.X := WinMinX - 1;
- DestCoor.Y := Y - 2;
- ClipRect := SrcRect;
- ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect, DestCoor, CharInfo);
- end; { proc. RemoveLine }
- procedure delline;
- begin
- removeline(wherey);
- end; { proc. DelLine }
- procedure insline;
- var
- ClipRect: TSmallRect;
- SrcRect: TSmallRect;
- DestCoor: TCoord;
- CharInfo: TCharInfo;
- X,Y: Longint;
- begin
- GetScreenCursor(X, Y);
- CharInfo.UnicodeChar := 32;
- CharInfo.Attributes := TextAttr;
- SrcRect.Top := Y - 1;
- SrcRect.Left := WinMinX - 1;
- SrcRect.Right := WinMaxX - 1;
- SrcRect.Bottom := WinMaxY - 1;
- DestCoor.X := WinMinX - 1;
- DestCoor.Y := Y;
- ClipRect := SrcRect;
- ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect, DestCoor, CharInfo);
- end; { proc. InsLine }
- {****************************************************************************
- Extra Crt Functions
- ****************************************************************************}
- procedure cursoron;
- var CursorInfo: TConsoleCursorInfo;
- begin
- GetConsoleCursorInfo(OutHandle, CursorInfo);
- CursorInfo.dwSize := SaveCursorSize;
- CursorInfo.bVisible := true;
- SetConsoleCursorInfo(OutHandle, CursorInfo);
- end;
- procedure cursoroff;
- var CursorInfo: TConsoleCursorInfo;
- begin
- GetConsoleCursorInfo(OutHandle, CursorInfo);
- CursorInfo.bVisible := false;
- SetConsoleCursorInfo(OutHandle, CursorInfo);
- end;
- procedure cursorbig;
- var CursorInfo: TConsoleCursorInfo;
- begin
- GetConsoleCursorInfo(OutHandle, CursorInfo);
- CursorInfo.dwSize := 100;
- CursorInfo.bVisible := true;
- SetConsoleCursorInfo(OutHandle, CursorInfo);
- end;
- {*****************************************************************************
- Read and Write routines
- *****************************************************************************}
- var
- CurrX, CurrY : longint;
- procedure WriteChar(c:char);
- var
- Cell : TCharInfo;
- BufSize : Coord; { Column-row size of source buffer }
- WritePos: TCoord; { Upper-left cell to write from }
- DestRect: TSmallRect;
- begin
- Case C of
- #10 : begin
- Inc(CurrY);
- end;
- #13 : begin
- CurrX := WinMinX;
- end; { if }
- #08 : begin
- if CurrX > WinMinX then Dec(CurrX);
- end; { ^H }
- #07 : begin
- // MessagBeep(0);
- end; { ^G }
- else begin
- BufSize.X := 01;
- BufSize.Y := 01;
- WritePos.X := 0;
- WritePos.Y := 0;
- Cell.UniCodeChar := Ord(c);
- Cell.Attributes := TextAttr;
- DestRect.Left := (CurrX - 01);
- DestRect.Top := (CurrY - 01);
- DestRect.Right := (CurrX - 01);
- DestRect.Bottom := (CurrY - 01);
- WriteConsoleOutput(OutHandle, Cell, BufSize, WritePos, @DestRect);
- Inc(CurrX);
- end; { else }
- end; { case }
- if CurrX > WinMaxX then
- begin
- CurrX := WinMinX;
- Inc(CurrY);
- end; { if }
- While CurrY > WinMaxY do
- begin
- RemoveLine(1);
- Dec(CurrY);
- end; { while }
- end;
- Function CrtWrite(var f : textrec):integer;
- var
- i : longint;
- begin
- GetScreenCursor(CurrX,CurrY);
- for i:=0 to f.bufpos-1 do
- WriteChar(f.buffer[i]);
- SetScreenCursor(CurrX,CurrY);
- f.bufpos:=0;
- CrtWrite:=0;
- end;
- Function CrtRead(Var F: TextRec): Integer;
- procedure BackSpace;
- begin
- if (f.bufpos>0) and (f.bufpos=f.bufend) then
- begin
- WriteChar(#8);
- WriteChar(' ');
- WriteChar(#8);
- dec(f.bufpos);
- dec(f.bufend);
- end;
- end;
- var
- ch : Char;
- Begin
- GetScreenCursor(CurrX,CurrY);
- f.bufpos:=0;
- f.bufend:=0;
- repeat
- if f.bufpos>f.bufend then
- f.bufend:=f.bufpos;
- SetScreenCursor(CurrX,CurrY);
- ch:=readkey;
- case ch of
- #0 : case readkey of
- #71 : while f.bufpos>0 do
- begin
- dec(f.bufpos);
- WriteChar(#8);
- end;
- #75 : if f.bufpos>0 then
- begin
- dec(f.bufpos);
- WriteChar(#8);
- end;
- #77 : if f.bufpos<f.bufend then
- begin
- WriteChar(f.bufptr^[f.bufpos]);
- inc(f.bufpos);
- end;
- #79 : while f.bufpos<f.bufend do
- begin
- WriteChar(f.bufptr^[f.bufpos]);
- inc(f.bufpos);
- end;
- end;
- ^S,
- #8 : BackSpace;
- ^Y,
- #27 : begin
- f.bufpos:=f.bufend;
- while f.bufend>0 do
- BackSpace;
- end;
- #13 : begin
- WriteChar(#13);
- WriteChar(#10);
- f.bufptr^[f.bufend]:=#13;
- f.bufptr^[f.bufend+1]:=#10;
- inc(f.bufend,2);
- break;
- end;
- #26 : if CheckEOF then
- begin
- f.bufptr^[f.bufend]:=#26;
- inc(f.bufend);
- break;
- end;
- else
- begin
- if f.bufpos<f.bufsize-2 then
- begin
- f.buffer[f.bufpos]:=ch;
- inc(f.bufpos);
- WriteChar(ch);
- end;
- end;
- end;
- until false;
- f.bufpos:=0;
- SetScreenCursor(CurrX,CurrY);
- CrtRead:=0;
- End;
- Function CrtReturn(Var F:TextRec):Integer;
- Begin
- CrtReturn:=0;
- end;
- Function CrtClose(Var F: TextRec): Integer;
- Begin
- F.Mode:=fmClosed;
- CrtClose:=0;
- End;
- Function CrtOpen(Var F: TextRec): Integer;
- Begin
- If F.Mode=fmOutput Then
- begin
- TextRec(F).InOutFunc:=@CrtWrite;
- TextRec(F).FlushFunc:=@CrtWrite;
- end
- Else
- begin
- F.Mode:=fmInput;
- TextRec(F).InOutFunc:=@CrtRead;
- TextRec(F).FlushFunc:=@CrtReturn;
- end;
- TextRec(F).CloseFunc:=@CrtClose;
- CrtOpen:=0;
- End;
- procedure AssignCrt(var F: Text);
- begin
- Assign(F,'');
- TextRec(F).OpenFunc:=@CrtOpen;
- end;
- var
- CursorInfo : TConsoleCursorInfo;
- ConsoleInfo : TConsoleScreenBufferinfo;
- begin
- { Initialize the output handles }
- OutHandle := GetStdHandle(STD_OUTPUT_HANDLE);
- InputHandle := GetStdHandle(STD_INPUT_HANDLE);
- LastMode := 3;
- {--------------------- Get the cursor size and such -----------------------}
- FillChar(CursorInfo, SizeOf(CursorInfo), 00);
- GetConsoleCursorInfo(OutHandle, CursorInfo);
- SaveCursorSize := CursorInfo.dwSize;
- {------------------ Get the current cursor position and attr --------------}
- FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0);
- GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
- CursorSaveX := ConsoleInfo.dwCursorPosition.X;
- CursorSaveY := ConsoleInfo.dwCursorPosition.Y;
- TextAttr := ConsoleInfo.wAttributes;
- { Load startup values }
- ScreenWidth := GetScreenWidth;
- ScreenHeight := GetScreenHeight;
- IsWindowsNT := (GetPlatformID = VER_PLATFORM_WIN32_NT);
- TurnMouseOff;
- WindMax := (ScreenWidth - 1) OR ((ScreenHeight - 1) SHL 8);
- DoingNumChars := false;
- DoingNumCode := 0;
- { Redirect the standard output }
- AssignCrt(Output);
- Rewrite(Output);
- TextRec(Output).Handle:= OutHandle;
- AssignCrt(Input);
- Reset(Input);
- TextRec(Input).Handle:= InputHandle;
- end. { unit Crt }
- {
- $Log$
- Revision 1.14 2000-02-26 14:57:17 florian
- * writing at coloumn <screenwidth> wasn't possible in some cases,
- fixed
- Revision 1.13 2000/02/09 16:59:34 peter
- * truncated log
- Revision 1.12 1999/10/22 14:36:20 peter
- * crtreturn also needs f:textrec as parameter
- Revision 1.11 1999/08/28 09:30:39 peter
- * fixes from Maarten Bekers
- Revision 1.10 1999/08/24 13:15:44 peter
- * Removeline fixed
- }
|