123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766 |
- { ***************************************************************************
- Copyright (c) 2016-2018 Kike Pérez
- Unit : Quick.Console
- Description : Console output with colors and optional file log
- Author : Kike Pérez
- Version : 1.8
- Created : 10/05/2017
- Modified : 09/03/2018
- This file is part of QuickLib: https://github.com/exilon/QuickLib
- ***************************************************************************
- Licensed under the Apache License, Version 2.0 (the "License");
- you may not use this file except in compliance with the License.
- You may obtain a copy of the License at
- http://www.apache.org/licenses/LICENSE-2.0
- Unless required by applicable law or agreed to in writing, software
- distributed under the License is distributed on an "AS IS" BASIS,
- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
- See the License for the specific language governing permissions and
- limitations under the License.
- *************************************************************************** }
- unit Quick.Console;
- {$IFDEF CONDITIONALEXPRESSIONS}
- {$ifndef VER140}
- {$ifndef LINUX}
- {$define WITHUXTHEME}
- {$endif}
- {$endif}
- {$IF CompilerVersion >= 17.0}
- {$DEFINE INLINES}
- {$ENDIF}
- {$IF RTLVersion >= 14.0}
- {$DEFINE HASERROUTPUT}
- {$ENDIF}
- {$ENDIF}
- interface
- uses
- Classes,
- Windows,
- Winapi.Messages,
- System.SysUtils,
- Quick.Commons,
- Quick.Log;
- type
- //text colors
- TConsoleColor = (
- ccBlack = 0,
- ccBlue = 1,
- ccGreen = 2,
- ccCyan = 3,
- ccRed = 4,
- ccMagenta = 5,
- ccBrown = 6,
- ccLightGray = 7,
- ccDarkGray = 8,
- ccLightBlue = 9,
- ccLightGreen = 10,
- ccLightCyan = 11,
- ccLightRed = 12,
- ccLightMagenta = 13,
- ccYellow = 14,
- ccWhite = 15);
- TConsoleProperties = record
- LogVerbose : TLogVerbose;
- Log : TQuickLog;
- end;
- TOutputProc<T> = reference to procedure(const aLine : T);
- TExecuteProc = reference to procedure;
- TConsoleMenuOption = record
- private
- fCaption : string;
- fKey : Word;
- fOnKeyPressed : TExecuteProc;
- public
- property Caption : string read fCaption write fCaption;
- property Key : Word read fKey write fKey;
- property OnKeyPressed : TExecuteProc read fOnKeyPressed write fOnKeyPressed;
- procedure DoKeyPressed;
- end;
- TConsoleMenu = class
- private
- fConsoleMenu : array of TConsoleMenuOption;
- fMenuColor : TConsoleColor;
- fIsActive : Boolean;
- procedure WriteMenu;
- public
- constructor Create;
- property MenuColor : TConsoleColor read fMenuColor write fMenuColor;
- property IsActive : Boolean read fIsActive;
- procedure AddMenu(const cMenuCaption : string; const cMenuKey : Word; MenuAction : TExecuteProc); overload;
- procedure AddMenu(MenuOption : TConsoleMenuOption); overload;
- procedure Refresh(aClearScreen : Boolean = False);
- procedure WaitForKeys;
- end;
- procedure cout(const cMsg : Integer; cEventType : TLogEventType); overload;
- procedure cout(const cMsg : Double; cEventType : TLogEventType); overload;
- procedure cout(const cMsg : string; cEventType : TLogEventType); overload;
- procedure cout(const cMsg : string; cColor : TConsoleColor); overload;
- procedure coutXY(x,y : Integer; const cMsg : string; cEventType : TLogEventType); overload;
- procedure coutXY(x,y : Integer; const cMsg : string; cColor : TConsoleColor); overload;
- procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cEventType : TLogEventType); overload;
- procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cColor : TConsoleColor); overload;
- procedure coutTL(const cMsg : string; cEventType : TLogEventType); overload;
- procedure coutTL(const cMsg : string; cColor : TConsoleColor); overload;
- procedure coutBL(const cMsg : string; cEventType : TLogEventType); overload;
- procedure coutBL(const cMsg : string; cColor : TConsoleColor); overload;
- procedure coutFmt(const cMsg : string; params : array of const; cEventType : TLogEventType);
- procedure TextColor(Color: TConsoleColor); overload;
- procedure TextColor(Color: Byte); overload;
- procedure TextBackground(Color: TConsoleColor); overload;
- procedure TextBackground(Color: Byte); overload;
- procedure ResetColors;
- procedure ConsoleResize(Width, Height : Integer);
- procedure ClearScreen;
- procedure ClearLine; overload;
- procedure ClearLine(Y : Integer); overload;
- procedure ShowCursor;
- procedure HideCursor;
- function GetCursorX: Integer; {$IFDEF INLINES}inline;{$ENDIF}
- function GetCursorY: Integer; {$IFDEF INLINES}inline;{$ENDIF}
- function GetCursorMaxBottom : Integer;
- procedure SetCursorPos(NewCoord : TCoord);
- procedure ProcessMessages;
- procedure ConsoleWaitForEnterKey;
- procedure RunConsoleCommand(const aCommand, aParameters : String; CallBack : TOutputProc<PAnsiChar> = nil; OutputLines : TStrings = nil);
- procedure InitConsole;
- var
- Console : TConsoleProperties;
- CSConsole : TRTLCriticalSection;
- LastMode : Word;
- DefConsoleColor : Byte;
- TextAttr : Byte;
- hStdOut: THandle;
- hStdErr: THandle;
- ConsoleRect: TSmallRect;
- ScreenBufInfo : TConsoleScreenBufferInfo;
- CursorInfo : TConsoleCursorInfo;
- implementation
- procedure cout(const cMsg : Integer; cEventType : TLogEventType);
- var
- FmtSets : TFormatSettings;
- begin
- try
- FmtSets := TFormatSettings.Create;
- FmtSets.ThousandSeparator := '.';
- FmtSets.DecimalSeparator := ',';
- cout(FormatFloat('0,',cMsg,FmtSets),cEventType);
- except
- cout(cMsg.ToString,cEventType);
- end;
- end;
- procedure cout(const cMsg : Double; cEventType : TLogEventType);
- var
- FmtSets : TFormatSettings;
- begin
- try
- FmtSets := TFormatSettings.Create;
- FmtSets.ThousandSeparator := '.';
- FmtSets.DecimalSeparator := ',';
- cout(FormatFloat('.0###,',cMsg,FmtSets),cEventType);
- except
- cout(cMsg.ToString,cEventType);
- end;
- end;
- procedure cout(const cMsg : string; cEventType : TLogEventType);
- begin
- if cEventType in Console.LogVerbose then
- begin
- EnterCriticalSection(CSConsole);
- try
- if hStdOut <> 0 then
- begin
- case cEventType of
- etError : TextColor(ccLightRed);
- etInfo : TextColor(ccWhite);
- etSuccess : TextColor(ccLightGreen);
- etWarning : TextColor(ccYellow);
- etDebug : TextColor(ccLightCyan);
- etTrace : TextColor(ccLightMagenta);
- else TextColor(ccWhite);
- end;
- Writeln(cMsg);
- TextColor(LastMode);
- end;
- finally
- LeaveCriticalSection(CSConsole);
- end;
- if Assigned(Console.Log) then Console.Log.Add(cMsg,cEventType);
- end;
- end;
- procedure cout(const cMsg : string; cColor : TConsoleColor);
- begin
- EnterCriticalSection(CSConsole);
- try
- if hStdOut <> 0 then
- begin
- TextColor(cColor);
- Writeln(cMsg);
- TextColor(LastMode);
- end;
- finally
- LeaveCriticalSection(CSConsole);
- end;
- end;
- function GetCursorX: Integer; {$IFDEF INLINES}inline;{$ENDIF}
- var
- BufferInfo: TConsoleScreenBufferInfo;
- begin
- GetConsoleSCreenBufferInfo(hStdOut, BufferInfo);
- Result := BufferInfo.dwCursorPosition.X;
- end;
- function GetCursorY: Integer; {$IFDEF INLINES}inline;{$ENDIF}
- var
- BufferInfo: TConsoleScreenBufferInfo;
- begin
- GetConsoleSCreenBufferInfo(hStdOut, BufferInfo);
- Result := BufferInfo.dwCursorPosition.Y;
- end;
- function GetCursorMaxBottom : Integer;
- var
- BufferInfo: TConsoleScreenBufferInfo;
- begin
- GetConsoleSCreenBufferInfo(hStdOut, BufferInfo);
- Result := BufferInfo.srWindow.Bottom;
- end;
- procedure SetCursorPos(NewCoord : TCoord);
- begin
- SetConsoleCursorPosition(hStdOut, NewCoord);
- end;
- procedure coutXY(x,y : Integer; const cMsg : string; cEventType : TLogEventType);
- var
- NewCoord : TCoord;
- LastCoord : TCoord;
- begin
- if hStdOut = 0 then Exit;
- LastCoord.X := GetCursorX;
- LastCoord.Y := GetCursorY;
- NewCoord.X := x;
- NewCoord.Y := y;
- ClearLine(Y);
- SetCursorPos(NewCoord);
- try
- cout(cMsg,cEventType);
- finally
- SetCursorPos(LastCoord);
- end;
- end;
- procedure coutXY(x,y : Integer; const cMsg : string; cColor : TConsoleColor); overload;
- var
- NewCoord : TCoord;
- LastCoord : TCoord;
- begin
- if hStdOut = 0 then Exit;
- LastCoord.X := GetCursorX;
- LastCoord.Y := GetCursorY;
- NewCoord.X := x;
- NewCoord.Y := y;
- ClearLine(Y);
- SetCursorPos(NewCoord);
- try
- cout(cMsg,cColor);
- finally
- SetCursorPos(LastCoord);
- end;
- end;
- procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cEventType : TLogEventType);
- begin
- coutXY(x,y,Format(cMsg,params),cEventType);
- end;
- procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cColor : TConsoleColor);
- begin
- coutXY(x,y,Format(cMsg,params),cColor);
- end;
- procedure coutTL(const cMsg : string; cEventType : TLogEventType);
- begin
- coutXY(0,0,cMsg,cEventType);
- end;
- procedure coutTL(const cMsg : string; cColor : TConsoleColor);
- begin
- coutXY(0,0,cMsg,cColor);
- end;
- procedure coutBL(const cMsg : string; cEventType : TLogEventType);
- begin
- coutXY(0,GetCursorMaxBottom - 1,cMsg,cEventType);
- end;
- procedure coutBL(const cMsg : string; cColor : TConsoleColor);
- begin
- coutXY(0,GetCursorMaxBottom - 1,cMsg,cColor);
- end;
- procedure coutFmt(const cMsg : string; params : array of const; cEventType : TLogEventType);
- begin
- cout(Format(cMsg,params),cEventType);
- end;
- procedure TextColor(Color: TConsoleColor);
- begin
- TextColor(Integer(Color));
- end;
- procedure TextColor(Color: Byte);
- begin
- if hStdOut = 0 then Exit;
- LastMode := TextAttr;
- TextAttr := (TextAttr and $F0) or (Color and $0F);
- if TextAttr <> LastMode then SetConsoleTextAttribute(hStdOut, TextAttr);
- end;
- procedure TextBackground(Color: TConsoleColor);
- begin
- TextBackground(Integer(Color));
- end;
- procedure TextBackground(Color: Byte);
- begin
- if hStdOut = 0 then Exit;
- LastMode := TextAttr;
- TextAttr := (TextAttr and $0F) or ((Color shl 4) and $F0);
- if TextAttr <> LastMode then SetConsoleTextAttribute(hStdOut, TextAttr);
- end;
- procedure ResetColors;
- begin
- SetConsoleTextAttribute(hStdOut, DefConsoleColor);
- TextAttr := DefConsoleColor;
- end;
- procedure ConsoleResize(Width, Height : Integer);
- var
- Rect: TSmallRect;
- Coord: TCoord;
- begin
- Rect.Left := 1;
- Rect.Top := 1;
- Rect.Right := Width;
- Rect.Bottom := Height;
- Coord.X := Rect.Right + 1 - Rect.Left;
- Coord.y := Rect.Bottom + 1 - Rect.Top;
- SetConsoleScreenBufferSize(GetStdHandle(STD_OUTPUT_HANDLE), Coord);
- SetConsoleWindowInfo(GetStdHandle(STD_OUTPUT_HANDLE), True, Rect);
- end;
- procedure ClearScreen;
- var
- stdout: THandle;
- bufinfo: TConsoleScreenBufferInfo;
- ConsoleSize: DWORD;
- NumWritten: DWORD;
- Origin: TCoord;
- begin
- stdout := GetStdHandle(STD_OUTPUT_HANDLE);
- if stdout<>INVALID_HANDLE_VALUE then
- begin
- GetConsoleScreenBufferInfo(stdout,bufinfo);
- ConsoleSize := bufinfo.dwSize.X * bufinfo.dwSize.Y;
- Origin.X := 0;
- Origin.Y := 0;
- FillConsoleOutputCharacter(stdout,' ',ConsoleSize,Origin,NumWritten);
- FillConsoleOutputAttribute(stdout,bufinfo.wAttributes,ConsoleSize,Origin,NumWritten);
- SetConsoleCursorPosition(stdout, Origin);
- end;
- end;
- procedure ClearLine;
- begin
- ClearLine(GetCursorY);
- end;
- procedure ClearLine(Y : Integer);
- var
- dwWriteCoord: TCoord;
- dwCount, dwSize: DWord;
- begin
- if hStdOut = 0 then Exit;
- dwWriteCoord.X := 0;
- dwWriteCoord.Y := Y;
- dwSize := ConsoleRect.Right + 1;
- FillConsoleOutputAttribute(hStdOut, TextAttr, dwSize, dwWriteCoord, dwCount);
- FillConsoleOutputCharacter(hStdOut, ' ', dwSize, dwWriteCoord, dwCount);
- end;
- procedure ShowCursor;
- begin
- GetConsoleCursorInfo(hStdOut,CursorInfo);
- CursorInfo.bVisible := True;
- SetConsoleCursorInfo(hStdOut,CursorInfo);
- end;
- procedure HideCursor;
- begin
- GetConsoleCursorInfo(hStdOut,CursorInfo);
- CursorInfo.bVisible := False;
- SetConsoleCursorInfo(hStdOut,CursorInfo);
- end;
- function ConsoleKeyPressed(ExpectedKey: Word): Boolean;
- var
- lpNumberOfEvents: DWORD;
- lpBuffer: TInputRecord;
- lpNumberOfEventsRead : DWORD;
- nStdHandle: THandle;
- begin
- Result := False;
- nStdHandle := GetStdHandle(STD_INPUT_HANDLE);
- lpNumberOfEvents := 0;
- GetNumberOfConsoleInputEvents(nStdHandle, lpNumberOfEvents);
- if lpNumberOfEvents <> 0 then
- begin
- PeekConsoleInput(nStdHandle, lpBuffer, 1, lpNumberOfEventsRead);
- if lpNumberOfEventsRead <> 0 then
- begin
- if lpBuffer.EventType = KEY_EVENT then
- begin
- if lpBuffer.Event.KeyEvent.bKeyDown and ((ExpectedKey = 0) or (lpBuffer.Event.KeyEvent.wVirtualKeyCode = ExpectedKey)) then Result := true
- else FlushConsoleInputBuffer(nStdHandle);
- end
- else FlushConsoleInputBuffer(nStdHandle);
- end;
- end;
- end;
- function GetConsoleKeyPressed : Word;
- var
- lpNumberOfEvents: DWORD;
- lpBuffer: TInputRecord;
- lpNumberOfEventsRead : DWORD;
- nStdHandle: THandle;
- begin
- Result := 0;
- nStdHandle := GetStdHandle(STD_INPUT_HANDLE);
- lpNumberOfEvents := 0;
- GetNumberOfConsoleInputEvents(nStdHandle, lpNumberOfEvents);
- if lpNumberOfEvents <> 0 then
- begin
- PeekConsoleInput(nStdHandle, lpBuffer, 1, lpNumberOfEventsRead);
- if lpNumberOfEventsRead <> 0 then
- begin
- if lpBuffer.EventType = KEY_EVENT then
- begin
- Result := lpBuffer.Event.KeyEvent.wVirtualKeyCode;
- FlushConsoleInputBuffer(nStdHandle);
- end
- else FlushConsoleInputBuffer(nStdHandle);
- end;
- end;
- end;
- procedure ProcessMessages;
- var
- Msg: TMsg;
- begin
- while integer(PeekMessage(Msg, 0, 0, 0, PM_REMOVE)) <> 0 do begin
- TranslateMessage(Msg);
- DispatchMessage(Msg);
- end;
- end;
- procedure ConsoleWaitForEnterKey;
- var
- msg: TMsg;
- begin
- while not ConsoleKeyPressed(VK_RETURN) do
- begin
- {$ifndef LVCL}
- if GetCurrentThreadID=MainThreadID then CheckSynchronize{$ifdef WITHUXTHEME}(1000){$endif} else
- {$endif}
- WaitMessage;
- while PeekMessage(msg,0,0,0,PM_REMOVE) do
- begin
- if Msg.Message = WM_QUIT then Exit
- else
- begin
- TranslateMessage(Msg);
- DispatchMessage(Msg);
- end;
- end;
- end;
- end;
- procedure RunConsoleCommand(const aCommand, aParameters : String; CallBack : TOutputProc<PAnsiChar> = nil; OutputLines : TStrings = nil);
- const
- CReadBuffer = 2400;
- var
- saSecurity: Windows.TSecurityAttributes;
- hRead: THandle;
- hWrite: THandle;
- suiStartup: TStartupInfo;
- piProcess: TProcessInformation;
- pBuffer: array [0..CReadBuffer] of AnsiChar;
- dBuffer: array [0..CReadBuffer] of AnsiChar;
- dRead: DWORD;
- dRunning: DWORD;
- dAvailable: DWORD;
- begin
- saSecurity.nLength := SizeOf(Windows.TSecurityAttributes);
- saSecurity.bInheritHandle := true;
- saSecurity.lpSecurityDescriptor := nil;
- if CreatePipe(hRead,hWrite,@saSecurity, 0) then
- begin
- try
- FillChar(suiStartup, SizeOf(TStartupInfo), #0);
- suiStartup.cb := SizeOf(TStartupInfo);
- suiStartup.hStdInput := hRead;
- suiStartup.hStdOutput := hWrite;
- suiStartup.hStdError := hWrite;
- suiStartup.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
- suiStartup.wShowWindow := SW_HIDE;
- if CreateProcess(nil,PChar(Format('%s %s',[aCommand,aParameters])),
- @saSecurity,
- @saSecurity,
- True,
- NORMAL_PRIORITY_CLASS,
- nil,
- nil,
- suiStartup,
- piProcess) then
- begin
- try
- repeat
- dRunning := WaitForSingleObject(piProcess.hProcess,100);
- PeekNamedPipe(hRead,nil,0,nil,@dAvailable,nil);
- if (dAvailable > 0) then
- begin
- repeat
- dRead := 0;
- ReadFile(hRead,pBuffer[0],CReadBuffer,dRead,nil);
- pBuffer[dRead] := #0;
- OemToCharA(pBuffer,dBuffer);
- if Assigned(CallBack) then CallBack(dBuffer);
- if Assigned(OutputLines) then OutputLines.Add(dBuffer);
- until (dRead < CReadBuffer);
- end;
- //Application.ProcessMessages;
- until (dRunning <> WAIT_TIMEOUT);
- finally
- CloseHandle(piProcess.hProcess);
- CloseHandle(piProcess.hThread);
- end;
- end;
- finally
- CloseHandle(hRead);
- CloseHandle(hWrite);
- end;
- end
- else raise Exception.Create('Can''t create pipe!');
- end;
- procedure InitConsole;
- var
- BufferInfo: TConsoleScreenBufferInfo;
- begin
- Console.LogVerbose := LOG_ALL;
- Rewrite(Output);
- hStdOut := TTextRec(Output).Handle;
- {$IFDEF HASERROUTPUT}
- Rewrite(ErrOutput);
- hStdErr := TTextRec(ErrOutput).Handle;
- {$ELSE}
- hStdErr := GetStdHandle(STD_ERROR_HANDLE);
- {$ENDIF}
- if not GetConsoleScreenBufferInfo(hStdOut, BufferInfo) then
- begin
- SetInOutRes(GetLastError);
- Exit;
- end;
- ConsoleRect.Left := 0;
- ConsoleRect.Top := 0;
- ConsoleRect.Right := BufferInfo.dwSize.X - 1;
- ConsoleRect.Bottom := BufferInfo.dwSize.Y - 1;
- TextAttr := BufferInfo.wAttributes and $FF;
- DefConsoleColor := TextAttr;
- LastMode := 3; //CO80;
- end;
- { TConsoleMenu }
- procedure TConsoleMenu.AddMenu(const cMenuCaption: string; const cMenuKey: Word; MenuAction: TExecuteProc);
- var
- conmenu : TConsoleMenuOption;
- begin
- conmenu.Caption := cMenuCaption;
- conmenu.Key := cMenuKey;
- conmenu.OnKeyPressed := MenuAction;
- fConsoleMenu := fConsoleMenu + [conmenu];
- end;
- procedure TConsoleMenu.AddMenu(MenuOption: TConsoleMenuOption);
- begin
- fConsoleMenu := fConsoleMenu + [MenuOption];
- end;
- constructor TConsoleMenu.Create;
- begin
- fMenuColor := ccLightCyan;
- fIsActive := False;
- end;
- procedure TConsoleMenu.Refresh(aClearScreen: Boolean);
- begin
- if aClearScreen then ClearScreen;
- WriteMenu;
- end;
- procedure TConsoleMenu.WaitForKeys;
- var
- msg: TMsg;
- conmenu : TConsoleMenuOption;
- keypressed : Word;
- begin
- fIsActive := True;
- HideCursor;
- WriteMenu;
- while True do
- begin
- //check key pressed
- keypressed := GetConsoleKeyPressed;
- for conmenu in fConsoleMenu do
- begin
- if keypressed = conmenu.Key then
- begin
- ClearScreen;
- WriteMenu;
- conmenu.DoKeyPressed;
- end;
- end;
- if keypressed = VK_ESCAPE then
- begin
- coutXY(50,12,'Exiting...',etInfo);
- Exit;
- end;
- {$ifndef LVCL}
- if GetCurrentThreadID=MainThreadID then CheckSynchronize{$ifdef WITHUXTHEME}(1000){$endif} else
- {$endif}
- WaitMessage;
- while PeekMessage(msg,0,0,0,PM_REMOVE) do
- begin
- if Msg.Message = WM_QUIT then Exit
- else
- begin
- TranslateMessage(Msg);
- DispatchMessage(Msg);
- end;
- end;
- end;
- ShowCursor;
- fIsActive := False;
- end;
- function GetCharFromVirtualKey(Key: Word): string;
- var
- keyboardState: TKeyboardState;
- asciiResult: Integer;
- begin
- GetKeyboardState(keyboardState) ;
- SetLength(Result, 2) ;
- asciiResult := ToAscii(key, MapVirtualKey(key, 0), keyboardState, @Result[1], 0) ;
- case asciiResult of
- 0: Result := '';
- 1: SetLength(Result, 1) ;
- 2:;
- else
- Result := '';
- end;
- end;
- procedure TConsoleMenu.WriteMenu;
- var
- conmenu : TConsoleMenuOption;
- ckey : string;
- coord : TCoord;
- oldcoord : TCoord;
- begin
- oldcoord.X := GetCursorX;
- oldcoord.Y := GetCursorY;
- coord.X := 0;
- coord.Y := 0;
- SetCursorPos(coord);
- TextColor(fMenuColor);
- ClearLine(0);
- for conmenu in fConsoleMenu do
- begin
- case conmenu.Key of
- VK_F1 : ckey := 'F1';
- VK_F2 : ckey := 'F2';
- VK_F3 : ckey := 'F3';
- VK_F4 : ckey := 'F4';
- VK_F5 : ckey := 'F5';
- VK_F6 : ckey := 'F6';
- VK_F7 : ckey := 'F7';
- VK_F8 : ckey := 'F8';
- VK_F9 : ckey := 'F9';
- VK_F10 : ckey := 'F10';
- VK_F11 : ckey := 'F11';
- VK_F12 : ckey := 'F12';
- else ckey := GetCharFromVirtualKey(conmenu.Key);
- end;
- TextColor(ccWhite);
- Write(Format('[%s]',[ckey]));
- TextColor(Self.MenuColor);
- Write(Format(' %s ',[conmenu.Caption]));
- end;
- TextColor(ccWhite);
- Write('[ESC]');
- TextColor(Self.MenuColor);
- Write(' Exit');
- TextColor(LastMode);
- SetCursorPos(oldcoord);
- end;
- { TConsoleMenuOption }
- procedure TConsoleMenuOption.DoKeyPressed;
- begin
- if Assigned(fOnKeyPressed) then fOnKeyPressed;
- end;
- initialization
- InitializeCriticalSection(CSConsole);
- //init stdout if not a service
- if GetStdHandle(STD_OUTPUT_HANDLE) <> 0 then InitConsole;
- finalization
- DeleteCriticalSection(CSConsole);
- end.
|