//*** CRT_EFD v1.20 - (c)1998-2000, EFD Systems *** // //Win32 console mode unit designed to reproduce the text mode //functionality found in the Crt unit of Turbo Pascal v7.0. See TP //for docs. Several new procedures have been added for convenience. // //Known, minor incompatabilities // - Direct manipulation of 'TextAttr' variable not supported, use SetTextattr(). // - Only text mode 'CO80' is supported. Mode constant 'Font8x8' sets 50 lines. // - Window() is not supported. // //v1.1 - Modified ReadKey to return proper control and extended key codes //v1.2 - Modified for D5 compatability // //LICENSE AGREEMENT and DISCLAIMER // //Copyrighted "freeware" for non-commercial use only. EFD Systems customers, //clients and software licensees have full, unrestricted use of this unit. // //THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF //ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO //THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A //PARTICULAR PURPOSE. // unit Crt_EFD; interface uses Windows, SysUtils; const Font8x8 = 256; C080 = 3; var LastMode,TextAttr:Word; //procedures corresponding to Turbo Pascal Crt unit procedure ClrEol; procedure ClrScr; procedure InsLine; procedure DelLine; function WhereX : Integer; function WhereY : Integer; procedure GotoXY(X,Y : Integer); procedure TextColor(Color:Word); procedure TextBackGround(Color:Word); procedure HighVideo; procedure LowVideo; procedure NormVideo; function KeyPressed : Boolean; function ReadKey : Char; procedure Delay(Ms: DWord); procedure Sound(Hz:DWord); procedure NoSound; procedure TextMode(Mode:Word); //additional procedures procedure FlushInputBuffer; procedure SetTextAttr(Color:Word); function GetTextAttr:Word; procedure SetCursor(Size:Integer; Visible:Bool); procedure WriteXY(Text:AnsiString; X,Y:Integer; Color:Word); procedure SetFullScreen; function GetConsoleWindow:THandle; {Useful and relevant API routines SetConsoleTitle() } implementation const FKeys = [#59..#68]; SKeys = [vk_shift,vk_control,vk_menu,vk_capital]; Ctrl_Pressed = Left_Ctrl_Pressed OR Right_Ctrl_Pressed; Alt_Pressed = Left_Alt_Pressed OR Right_Alt_Pressed; var InRec:TInputRecord; LastKey:Char=#32; LastScan:Char=#32; CurMode,NormAttr:Word; hStdIn:THandle = 0; hStdOut:THandle = 0; hStdErr:THandle = 0; hConsole:Thandle = 0; BI : TConsoleScreenBufferInfo; AltKey:AnsiString = '-0123456789=abcdefghijklmnopqrstuvwxyz'; CvtKey:AnsiString = #130#129#120#121#122#123#124#125#126#127#128+ #131#30#48#46#32#18#33#34#35#23#36#37#38+ #50#49#24#25#16#19#31#20#22#47#17#45#21#44; procedure ClrEol; var L, N : DWord; begin GetConsoleScreenBufferInfo(hStdOut, BI); with BI do begin L := dwSize.x-dwCursorPosition.x; FillConsoleOutputAttribute(hStdOut, TextAttr, L, dwCursorPosition, N); FillConsoleOutputCharacter(hStdOut, ' ', L, dwCursorPosition, N); end; end; procedure ClrScr; var L,N : DWord; begin GetConsoleScreenBufferInfo(hStdOut, BI); with BI do begin dwCursorPosition.x:=0; dwCursorPosition.y:=0; L:=dwSize.x*dwSize.y; FillConsoleOutputAttribute(hStdOut, TextAttr, L, dwCursorPosition, N); FillConsoleOutputCharacter(hStdOut, ' ', L, dwCursorPosition, N); SetConsoleCursorPosition(hStdout, dwCursorPosition); end; end; function KeyPressed : Boolean; var I : DWord; begin GetNumberofConsoleInputEvents(hStdIn,I); Result:=I>0; end; function ReadKey : Char; var I : DWord; OK : Boolean; begin if LastKey=#0 then Result:=LastScan else begin {$ifdef VER120} with InRec.Event.KeyEvent do begin {$else}{$ifdef VER130} with InRec.Event.KeyEvent do begin {$else} with InRec.Event.KeyEvent do begin {$endif}{$endif} repeat repeat Ok:=ReadConsoleInput(hStdIn,InRec,1,I); until OK and (InRec.EventType=KEY_EVENT) and (bKeyDown=False); LastScan:=Char(wVirtualScanCode); until not (wVirtualKeyCode in SKeys); Result:=AsciiChar; if dwControlKeyState<>0 then begin if Result=#0 then begin if (dwControlKeyState and Shift_Pressed)<>0 then begin if LastScan in FKeys then LastScan:=Char(Ord(LastScan)+25); end else if (dwControlKeyState and Ctrl_Pressed)<>0 then begin if LastScan in FKeys then LastScan:=Char(Ord(LastScan)+35) else case LastScan of #55:LastScan:=#114; #73:LastScan:=#132; #75:LastScan:=#115; #77:LastScan:=#116; #79:LastScan:=#117; #81:LastScan:=#118; end; end else if (dwControlKeyState and Alt_Pressed)<>0 then begin if LastScan in FKeys then LastScan:=Char(Ord(LastScan)+45); end; end else begin if (dwControlKeyState and Ctrl_Pressed)<>0 then begin if Result in ['a'..'z'] then Result:=Char(Ord(Result)-96) end else if (dwControlKeyState and Alt_Pressed)<>0 then begin I:=Pos(Result,AltKey); if I>0 then begin LastScan:=CvtKey[I]; Result:=#0; end; end else if (dwControlKeyState and Shift_Pressed)<>0 then begin if Result=#9 then begin Result:=#0; LastScan:=#15; end else CharUpper(PChar(Result)); end; end; end; end; end; LastKey:=Result; end; function WhereX : Integer; begin GetConsoleScreenBufferInfo(hStdOut, BI); Result := BI.dwCursorPosition.x+1; end; function WhereY : Integer; begin GetConsoleScreenBufferInfo(hStdOut, BI); Result := BI.dwCursorPosition.y+1; end; procedure GotoXY(X,Y : Integer); var Coord : TCoord; begin Coord.x := X-1; Coord.y := Y-1; SetConsoleCursorPosition(hStdOut, Coord) end; procedure TextColor(Color : Word); begin TextAttr := (TextAttr AND $F0) OR Color; SetConsoleTextAttribute(hStdOut,TextAttr); end; procedure TextBackGround(Color : Word); begin if Color<16 then Color := Color SHL 4; TextAttr:=(TextAttr AND $F) OR Color; SetConsoleTextAttribute(hStdOut,TextAttr); end; procedure HighVideo; begin TextAttr := TextAttr OR $8; SetConsoleTextAttribute(hStdOut, TextAttr); end; procedure LowVideo; begin TextAttr := TextAttr AND $F7; SetConsoleTextAttribute(hStdOut, TextAttr); end; procedure NormVideo; begin TextAttr := NormAttr; SetConsoleTextAttribute(hStdOut, TextAttr); end; procedure ScrollV(YDelta : SmallInt); var CI : TCharInfo; begin GetConsoleScreenBufferInfo(hStdOut, BI); with BI do begin CI.AsciiChar := ' '; CI.Attributes := TextAttr; dwCursorPosition.x:=0; if YDelta<0 then Inc(dwCursorPosition.y); srWindow.Left:=dwCursorPosition.x; srWindow.Top:=dwCursorPosition.y; Inc(dwCursorPosition.y,YDelta); ScrollConsoleScreenBuffer(hStdOut, srWindow, NIL, dwCursorPosition, CI); end; end; procedure InsLine; begin ScrollV(1); Dec(BI.dwCursorPosition.y); SetConsoleCursorPosition(hStdOut, BI.dwCursorPosition); end; procedure DelLine; begin ScrollV(-1); SetConsoleCursorPosition(hStdOut, BI.dwCursorPosition); end; procedure Delay(Ms: DWord); begin Sleep(Ms); end; procedure Sound(Hz : DWord); begin Windows.Beep(Hz, $FFFFFFFF); end; procedure NoSound; begin Windows.Beep(0, 0); end; procedure TextMode(Mode : Word); var Coord : TCoord; begin Coord.X := 80; if (Mode AND Font8x8)<>0 then Coord.Y := 50 else Coord.Y := 25; if SetConsoleScreenBufferSize(hStdOut,Coord) then begin LastMode := CurMode; CurMode := Mode; end; end; //New convenience procedures below ----------------------------- procedure FlushInputBuffer; //Clear all pending input var I:DWord; begin I:=0; repeat if FlushConsoleInputBuffer(hStdIn) then begin Sleep(150); GetNumberofConsoleInputEvents(hStdIn,I); end else Break; until I=0; end; procedure WriteXY(Text : AnsiString; X,Y : Integer; Color : Word); //Write string in specified color at given location var Coord : TCoord; N : DWord; begin Coord.x := X-1; Coord.y := Y-1; SetConsoleCursorPosition(hStdOut, Coord); Write(Text); FillConsoleOutputAttribute(hStdOut, Color, Length(Text), Coord, N); end; procedure SetCursor(Size : Integer; Visible : Bool); //Set cursor size and visibility var CI : TConsoleCursorInfo; begin GetConsoleCursorInfo(hStdOut,CI); if (Size>0) AND (Size<=100) then CI.dwSize := Size; CI.bVisible := Visible; SetConsoleCursorInfo(hStdOut,CI); end; procedure SetTextAttr(Color:Word); //Set default text attributes begin TextAttr := Color; SetConsoleTextAttribute(hStdOut, TextAttr); end; function GetTextAttr:Word; begin Result:=TextAttr; end; function GetConsoleWindow:THandle; //Get handle for console Window var S:AnsiString; C:Char; begin Result:=0; Setlength(S,MAX_PATH+1); if GetConsoleTitle(PChar(S),MAX_PATH)<>0 then begin C:=S[1]; S[1]:='$'; SetConsoleTitle(PChar(S)); hConsole:=FindWindow(nil,PChar(S)); S[1]:=C; SetConsoleTitle(PChar(S)); Result:=hConsole; end; end; procedure SetFullScreen; //switch console into full screen mode begin keybd_event( VK_MENU, MapVirtualKey( VK_MENU, 0 ), 0, 0 ); keybd_event( VK_RETURN, MapVirtualKey( VK_RETURN, 0 ), 0, 0 ); keybd_event( VK_RETURN, MapVirtualKey( VK_RETURN, 0 ),KEYEVENTF_KEYUP, 0 ); keybd_event( VK_MENU, MapVirtualKey( VK_MENU, 0 ), KEYEVENTF_KEYUP, 0); end; initialization hStdIn := GetStdHandle(STD_INPUT_HANDLE); hStdOut := GetStdHandle(STD_OUTPUT_HANDLE); hStdErr := GetStdHandle(STD_ERROR_HANDLE); SetConsoleMode(hStdIn,Enable_Line_Input OR Enable_Echo_Input or Enable_Processed_Input); FlushConsoleInputBuffer(hStdIn); GetConsoleScreenBufferInfo(hStdOut, BI); if BI.dwSize.Y>25 then LastMode := 256 else LastMode := 3; CurMode := LastMode; NormAttr := BI.wAttributes; TextAttr := NormAttr; end.