Quick.Console.pas 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771
  1. { ***************************************************************************
  2. Copyright (c) 2016-2018 Kike Pérez
  3. Unit : Quick.Console
  4. Description : Console output with colors and optional file log
  5. Author : Kike Pérez
  6. Version : 1.8
  7. Created : 10/05/2017
  8. Modified : 09/03/2018
  9. This file is part of QuickLib: https://github.com/exilon/QuickLib
  10. ***************************************************************************
  11. Licensed under the Apache License, Version 2.0 (the "License");
  12. you may not use this file except in compliance with the License.
  13. You may obtain a copy of the License at
  14. http://www.apache.org/licenses/LICENSE-2.0
  15. Unless required by applicable law or agreed to in writing, software
  16. distributed under the License is distributed on an "AS IS" BASIS,
  17. WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  18. See the License for the specific language governing permissions and
  19. limitations under the License.
  20. *************************************************************************** }
  21. unit Quick.Console;
  22. {$IFDEF CONDITIONALEXPRESSIONS}
  23. {$ifndef VER140}
  24. {$ifndef LINUX}
  25. {$define WITHUXTHEME}
  26. {$endif}
  27. {$endif}
  28. {$IF CompilerVersion >= 17.0}
  29. {$DEFINE INLINES}
  30. {$ENDIF}
  31. {$IF RTLVersion >= 14.0}
  32. {$DEFINE HASERROUTPUT}
  33. {$ENDIF}
  34. {$ENDIF}
  35. interface
  36. uses
  37. Classes,
  38. Windows,
  39. Winapi.Messages,
  40. System.SysUtils,
  41. Quick.Commons,
  42. Quick.Log;
  43. type
  44. //text colors
  45. TConsoleColor = (
  46. ccBlack = 0,
  47. ccBlue = 1,
  48. ccGreen = 2,
  49. ccCyan = 3,
  50. ccRed = 4,
  51. ccMagenta = 5,
  52. ccBrown = 6,
  53. ccLightGray = 7,
  54. ccDarkGray = 8,
  55. ccLightBlue = 9,
  56. ccLightGreen = 10,
  57. ccLightCyan = 11,
  58. ccLightRed = 12,
  59. ccLightMagenta = 13,
  60. ccYellow = 14,
  61. ccWhite = 15);
  62. TConsoleProperties = record
  63. LogVerbose : TLogVerbose;
  64. Log : TQuickLog;
  65. end;
  66. TOutputProc<T> = reference to procedure(const aLine : T);
  67. TExecuteProc = reference to procedure;
  68. TConsoleMenuOption = record
  69. private
  70. fCaption : string;
  71. fKey : Word;
  72. fOnKeyPressed : TExecuteProc;
  73. public
  74. property Caption : string read fCaption write fCaption;
  75. property Key : Word read fKey write fKey;
  76. property OnKeyPressed : TExecuteProc read fOnKeyPressed write fOnKeyPressed;
  77. procedure DoKeyPressed;
  78. end;
  79. TConsoleMenu = class
  80. private
  81. fConsoleMenu : array of TConsoleMenuOption;
  82. fMenuColor : TConsoleColor;
  83. fIsActive : Boolean;
  84. procedure WriteMenu;
  85. public
  86. constructor Create;
  87. property MenuColor : TConsoleColor read fMenuColor write fMenuColor;
  88. property IsActive : Boolean read fIsActive;
  89. procedure AddMenu(const cMenuCaption : string; const cMenuKey : Word; MenuAction : TExecuteProc); overload;
  90. procedure AddMenu(MenuOption : TConsoleMenuOption); overload;
  91. procedure Refresh(aClearScreen : Boolean = False);
  92. procedure WaitForKeys;
  93. end;
  94. procedure cout(const cMsg : Integer; cEventType : TLogEventType); overload;
  95. procedure cout(const cMsg : Double; cEventType : TLogEventType); overload;
  96. procedure cout(const cMsg : string; cEventType : TLogEventType); overload;
  97. procedure cout(const cMsg : string; cColor : TConsoleColor); overload;
  98. procedure cout(const cMsg : string; params : array of const; cEventType : TLogEventType); overload;
  99. procedure coutXY(x,y : Integer; const cMsg : string; cEventType : TLogEventType); overload;
  100. procedure coutXY(x,y : Integer; const cMsg : string; cColor : TConsoleColor); overload;
  101. procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cEventType : TLogEventType); overload;
  102. procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cColor : TConsoleColor); overload;
  103. procedure coutTL(const cMsg : string; cEventType : TLogEventType); overload;
  104. procedure coutTL(const cMsg : string; cColor : TConsoleColor); overload;
  105. procedure coutBL(const cMsg : string; cEventType : TLogEventType); overload;
  106. procedure coutBL(const cMsg : string; cColor : TConsoleColor); overload;
  107. procedure coutFmt(const cMsg : string; params : array of const; cEventType : TLogEventType);
  108. procedure TextColor(Color: TConsoleColor); overload;
  109. procedure TextColor(Color: Byte); overload;
  110. procedure TextBackground(Color: TConsoleColor); overload;
  111. procedure TextBackground(Color: Byte); overload;
  112. procedure ResetColors;
  113. procedure ConsoleResize(Width, Height : Integer);
  114. procedure ClearScreen;
  115. procedure ClearLine; overload;
  116. procedure ClearLine(Y : Integer); overload;
  117. procedure ShowCursor;
  118. procedure HideCursor;
  119. function GetCursorX: Integer; {$IFDEF INLINES}inline;{$ENDIF}
  120. function GetCursorY: Integer; {$IFDEF INLINES}inline;{$ENDIF}
  121. function GetCursorMaxBottom : Integer;
  122. procedure SetCursorPos(NewCoord : TCoord);
  123. procedure ProcessMessages;
  124. procedure ConsoleWaitForEnterKey;
  125. procedure RunConsoleCommand(const aCommand, aParameters : String; CallBack : TOutputProc<PAnsiChar> = nil; OutputLines : TStrings = nil);
  126. procedure InitConsole;
  127. var
  128. Console : TConsoleProperties;
  129. CSConsole : TRTLCriticalSection;
  130. LastMode : Word;
  131. DefConsoleColor : Byte;
  132. TextAttr : Byte;
  133. hStdOut: THandle;
  134. hStdErr: THandle;
  135. ConsoleRect: TSmallRect;
  136. ScreenBufInfo : TConsoleScreenBufferInfo;
  137. CursorInfo : TConsoleCursorInfo;
  138. implementation
  139. procedure cout(const cMsg : Integer; cEventType : TLogEventType);
  140. var
  141. FmtSets : TFormatSettings;
  142. begin
  143. try
  144. FmtSets := TFormatSettings.Create;
  145. FmtSets.ThousandSeparator := '.';
  146. FmtSets.DecimalSeparator := ',';
  147. cout(FormatFloat('0,',cMsg,FmtSets),cEventType);
  148. except
  149. cout(cMsg.ToString,cEventType);
  150. end;
  151. end;
  152. procedure cout(const cMsg : Double; cEventType : TLogEventType);
  153. var
  154. FmtSets : TFormatSettings;
  155. begin
  156. try
  157. FmtSets := TFormatSettings.Create;
  158. FmtSets.ThousandSeparator := '.';
  159. FmtSets.DecimalSeparator := ',';
  160. cout(FormatFloat('.0###,',cMsg,FmtSets),cEventType);
  161. except
  162. cout(cMsg.ToString,cEventType);
  163. end;
  164. end;
  165. procedure cout(const cMsg : string; cEventType : TLogEventType);
  166. begin
  167. if cEventType in Console.LogVerbose then
  168. begin
  169. EnterCriticalSection(CSConsole);
  170. try
  171. if hStdOut <> 0 then
  172. begin
  173. case cEventType of
  174. etError : TextColor(ccLightRed);
  175. etInfo : TextColor(ccWhite);
  176. etSuccess : TextColor(ccLightGreen);
  177. etWarning : TextColor(ccYellow);
  178. etDebug : TextColor(ccLightCyan);
  179. etTrace : TextColor(ccLightMagenta);
  180. else TextColor(ccWhite);
  181. end;
  182. Writeln(cMsg);
  183. TextColor(LastMode);
  184. end;
  185. finally
  186. LeaveCriticalSection(CSConsole);
  187. end;
  188. if Assigned(Console.Log) then Console.Log.Add(cMsg,cEventType);
  189. end;
  190. end;
  191. procedure cout(const cMsg : string; cColor : TConsoleColor);
  192. begin
  193. EnterCriticalSection(CSConsole);
  194. try
  195. if hStdOut <> 0 then
  196. begin
  197. TextColor(cColor);
  198. Writeln(cMsg);
  199. TextColor(LastMode);
  200. end;
  201. finally
  202. LeaveCriticalSection(CSConsole);
  203. end;
  204. end;
  205. procedure cout(const cMsg : string; params : array of const; cEventType : TLogEventType);
  206. begin
  207. cout(Format(cMsg,params),cEventType);
  208. end;
  209. function GetCursorX: Integer; {$IFDEF INLINES}inline;{$ENDIF}
  210. var
  211. BufferInfo: TConsoleScreenBufferInfo;
  212. begin
  213. GetConsoleSCreenBufferInfo(hStdOut, BufferInfo);
  214. Result := BufferInfo.dwCursorPosition.X;
  215. end;
  216. function GetCursorY: Integer; {$IFDEF INLINES}inline;{$ENDIF}
  217. var
  218. BufferInfo: TConsoleScreenBufferInfo;
  219. begin
  220. GetConsoleSCreenBufferInfo(hStdOut, BufferInfo);
  221. Result := BufferInfo.dwCursorPosition.Y;
  222. end;
  223. function GetCursorMaxBottom : Integer;
  224. var
  225. BufferInfo: TConsoleScreenBufferInfo;
  226. begin
  227. GetConsoleSCreenBufferInfo(hStdOut, BufferInfo);
  228. Result := BufferInfo.srWindow.Bottom;
  229. end;
  230. procedure SetCursorPos(NewCoord : TCoord);
  231. begin
  232. SetConsoleCursorPosition(hStdOut, NewCoord);
  233. end;
  234. procedure coutXY(x,y : Integer; const cMsg : string; cEventType : TLogEventType);
  235. var
  236. NewCoord : TCoord;
  237. LastCoord : TCoord;
  238. begin
  239. if hStdOut = 0 then Exit;
  240. LastCoord.X := GetCursorX;
  241. LastCoord.Y := GetCursorY;
  242. NewCoord.X := x;
  243. NewCoord.Y := y;
  244. ClearLine(Y);
  245. SetCursorPos(NewCoord);
  246. try
  247. cout(cMsg,cEventType);
  248. finally
  249. SetCursorPos(LastCoord);
  250. end;
  251. end;
  252. procedure coutXY(x,y : Integer; const cMsg : string; cColor : TConsoleColor); overload;
  253. var
  254. NewCoord : TCoord;
  255. LastCoord : TCoord;
  256. begin
  257. if hStdOut = 0 then Exit;
  258. LastCoord.X := GetCursorX;
  259. LastCoord.Y := GetCursorY;
  260. NewCoord.X := x;
  261. NewCoord.Y := y;
  262. ClearLine(Y);
  263. SetCursorPos(NewCoord);
  264. try
  265. cout(cMsg,cColor);
  266. finally
  267. SetCursorPos(LastCoord);
  268. end;
  269. end;
  270. procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cEventType : TLogEventType);
  271. begin
  272. coutXY(x,y,Format(cMsg,params),cEventType);
  273. end;
  274. procedure coutXY(x,y : Integer; const cMsg : string; params : array of const; cColor : TConsoleColor);
  275. begin
  276. coutXY(x,y,Format(cMsg,params),cColor);
  277. end;
  278. procedure coutTL(const cMsg : string; cEventType : TLogEventType);
  279. begin
  280. coutXY(0,0,cMsg,cEventType);
  281. end;
  282. procedure coutTL(const cMsg : string; cColor : TConsoleColor);
  283. begin
  284. coutXY(0,0,cMsg,cColor);
  285. end;
  286. procedure coutBL(const cMsg : string; cEventType : TLogEventType);
  287. begin
  288. coutXY(0,GetCursorMaxBottom - 1,cMsg,cEventType);
  289. end;
  290. procedure coutBL(const cMsg : string; cColor : TConsoleColor);
  291. begin
  292. coutXY(0,GetCursorMaxBottom - 1,cMsg,cColor);
  293. end;
  294. procedure coutFmt(const cMsg : string; params : array of const; cEventType : TLogEventType);
  295. begin
  296. cout(Format(cMsg,params),cEventType);
  297. end;
  298. procedure TextColor(Color: TConsoleColor);
  299. begin
  300. TextColor(Integer(Color));
  301. end;
  302. procedure TextColor(Color: Byte);
  303. begin
  304. if hStdOut = 0 then Exit;
  305. LastMode := TextAttr;
  306. TextAttr := (TextAttr and $F0) or (Color and $0F);
  307. if TextAttr <> LastMode then SetConsoleTextAttribute(hStdOut, TextAttr);
  308. end;
  309. procedure TextBackground(Color: TConsoleColor);
  310. begin
  311. TextBackground(Integer(Color));
  312. end;
  313. procedure TextBackground(Color: Byte);
  314. begin
  315. if hStdOut = 0 then Exit;
  316. LastMode := TextAttr;
  317. TextAttr := (TextAttr and $0F) or ((Color shl 4) and $F0);
  318. if TextAttr <> LastMode then SetConsoleTextAttribute(hStdOut, TextAttr);
  319. end;
  320. procedure ResetColors;
  321. begin
  322. SetConsoleTextAttribute(hStdOut, DefConsoleColor);
  323. TextAttr := DefConsoleColor;
  324. end;
  325. procedure ConsoleResize(Width, Height : Integer);
  326. var
  327. Rect: TSmallRect;
  328. Coord: TCoord;
  329. begin
  330. Rect.Left := 1;
  331. Rect.Top := 1;
  332. Rect.Right := Width;
  333. Rect.Bottom := Height;
  334. Coord.X := Rect.Right + 1 - Rect.Left;
  335. Coord.y := Rect.Bottom + 1 - Rect.Top;
  336. SetConsoleScreenBufferSize(GetStdHandle(STD_OUTPUT_HANDLE), Coord);
  337. SetConsoleWindowInfo(GetStdHandle(STD_OUTPUT_HANDLE), True, Rect);
  338. end;
  339. procedure ClearScreen;
  340. var
  341. stdout: THandle;
  342. bufinfo: TConsoleScreenBufferInfo;
  343. ConsoleSize: DWORD;
  344. NumWritten: DWORD;
  345. Origin: TCoord;
  346. begin
  347. stdout := GetStdHandle(STD_OUTPUT_HANDLE);
  348. if stdout<>INVALID_HANDLE_VALUE then
  349. begin
  350. GetConsoleScreenBufferInfo(stdout,bufinfo);
  351. ConsoleSize := bufinfo.dwSize.X * bufinfo.dwSize.Y;
  352. Origin.X := 0;
  353. Origin.Y := 0;
  354. FillConsoleOutputCharacter(stdout,' ',ConsoleSize,Origin,NumWritten);
  355. FillConsoleOutputAttribute(stdout,bufinfo.wAttributes,ConsoleSize,Origin,NumWritten);
  356. SetConsoleCursorPosition(stdout, Origin);
  357. end;
  358. end;
  359. procedure ClearLine;
  360. begin
  361. ClearLine(GetCursorY);
  362. end;
  363. procedure ClearLine(Y : Integer);
  364. var
  365. dwWriteCoord: TCoord;
  366. dwCount, dwSize: DWord;
  367. begin
  368. if hStdOut = 0 then Exit;
  369. dwWriteCoord.X := 0;
  370. dwWriteCoord.Y := Y;
  371. dwSize := ConsoleRect.Right + 1;
  372. FillConsoleOutputAttribute(hStdOut, TextAttr, dwSize, dwWriteCoord, dwCount);
  373. FillConsoleOutputCharacter(hStdOut, ' ', dwSize, dwWriteCoord, dwCount);
  374. end;
  375. procedure ShowCursor;
  376. begin
  377. GetConsoleCursorInfo(hStdOut,CursorInfo);
  378. CursorInfo.bVisible := True;
  379. SetConsoleCursorInfo(hStdOut,CursorInfo);
  380. end;
  381. procedure HideCursor;
  382. begin
  383. GetConsoleCursorInfo(hStdOut,CursorInfo);
  384. CursorInfo.bVisible := False;
  385. SetConsoleCursorInfo(hStdOut,CursorInfo);
  386. end;
  387. function ConsoleKeyPressed(ExpectedKey: Word): Boolean;
  388. var
  389. lpNumberOfEvents: DWORD;
  390. lpBuffer: TInputRecord;
  391. lpNumberOfEventsRead : DWORD;
  392. nStdHandle: THandle;
  393. begin
  394. Result := False;
  395. nStdHandle := GetStdHandle(STD_INPUT_HANDLE);
  396. lpNumberOfEvents := 0;
  397. GetNumberOfConsoleInputEvents(nStdHandle, lpNumberOfEvents);
  398. if lpNumberOfEvents <> 0 then
  399. begin
  400. PeekConsoleInput(nStdHandle, lpBuffer, 1, lpNumberOfEventsRead);
  401. if lpNumberOfEventsRead <> 0 then
  402. begin
  403. if lpBuffer.EventType = KEY_EVENT then
  404. begin
  405. if lpBuffer.Event.KeyEvent.bKeyDown and ((ExpectedKey = 0) or (lpBuffer.Event.KeyEvent.wVirtualKeyCode = ExpectedKey)) then Result := true
  406. else FlushConsoleInputBuffer(nStdHandle);
  407. end
  408. else FlushConsoleInputBuffer(nStdHandle);
  409. end;
  410. end;
  411. end;
  412. function GetConsoleKeyPressed : Word;
  413. var
  414. lpNumberOfEvents: DWORD;
  415. lpBuffer: TInputRecord;
  416. lpNumberOfEventsRead : DWORD;
  417. nStdHandle: THandle;
  418. begin
  419. Result := 0;
  420. nStdHandle := GetStdHandle(STD_INPUT_HANDLE);
  421. lpNumberOfEvents := 0;
  422. GetNumberOfConsoleInputEvents(nStdHandle, lpNumberOfEvents);
  423. if lpNumberOfEvents <> 0 then
  424. begin
  425. PeekConsoleInput(nStdHandle, lpBuffer, 1, lpNumberOfEventsRead);
  426. if lpNumberOfEventsRead <> 0 then
  427. begin
  428. if lpBuffer.EventType = KEY_EVENT then
  429. begin
  430. Result := lpBuffer.Event.KeyEvent.wVirtualKeyCode;
  431. FlushConsoleInputBuffer(nStdHandle);
  432. end
  433. else FlushConsoleInputBuffer(nStdHandle);
  434. end;
  435. end;
  436. end;
  437. procedure ProcessMessages;
  438. var
  439. Msg: TMsg;
  440. begin
  441. while integer(PeekMessage(Msg, 0, 0, 0, PM_REMOVE)) <> 0 do begin
  442. TranslateMessage(Msg);
  443. DispatchMessage(Msg);
  444. end;
  445. end;
  446. procedure ConsoleWaitForEnterKey;
  447. var
  448. msg: TMsg;
  449. begin
  450. while not ConsoleKeyPressed(VK_RETURN) do
  451. begin
  452. {$ifndef LVCL}
  453. if GetCurrentThreadID=MainThreadID then CheckSynchronize{$ifdef WITHUXTHEME}(1000){$endif} else
  454. {$endif}
  455. WaitMessage;
  456. while PeekMessage(msg,0,0,0,PM_REMOVE) do
  457. begin
  458. if Msg.Message = WM_QUIT then Exit
  459. else
  460. begin
  461. TranslateMessage(Msg);
  462. DispatchMessage(Msg);
  463. end;
  464. end;
  465. end;
  466. end;
  467. procedure RunConsoleCommand(const aCommand, aParameters : String; CallBack : TOutputProc<PAnsiChar> = nil; OutputLines : TStrings = nil);
  468. const
  469. CReadBuffer = 2400;
  470. var
  471. saSecurity: Windows.TSecurityAttributes;
  472. hRead: THandle;
  473. hWrite: THandle;
  474. suiStartup: TStartupInfo;
  475. piProcess: TProcessInformation;
  476. pBuffer: array [0..CReadBuffer] of AnsiChar;
  477. dBuffer: array [0..CReadBuffer] of AnsiChar;
  478. dRead: DWORD;
  479. dRunning: DWORD;
  480. dAvailable: DWORD;
  481. begin
  482. saSecurity.nLength := SizeOf(Windows.TSecurityAttributes);
  483. saSecurity.bInheritHandle := true;
  484. saSecurity.lpSecurityDescriptor := nil;
  485. if CreatePipe(hRead,hWrite,@saSecurity, 0) then
  486. begin
  487. try
  488. FillChar(suiStartup, SizeOf(TStartupInfo), #0);
  489. suiStartup.cb := SizeOf(TStartupInfo);
  490. suiStartup.hStdInput := hRead;
  491. suiStartup.hStdOutput := hWrite;
  492. suiStartup.hStdError := hWrite;
  493. suiStartup.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  494. suiStartup.wShowWindow := SW_HIDE;
  495. if CreateProcess(nil,PChar(Format('%s %s',[aCommand,aParameters])),
  496. @saSecurity,
  497. @saSecurity,
  498. True,
  499. NORMAL_PRIORITY_CLASS,
  500. nil,
  501. nil,
  502. suiStartup,
  503. piProcess) then
  504. begin
  505. try
  506. repeat
  507. dRunning := WaitForSingleObject(piProcess.hProcess,100);
  508. PeekNamedPipe(hRead,nil,0,nil,@dAvailable,nil);
  509. if (dAvailable > 0) then
  510. begin
  511. repeat
  512. dRead := 0;
  513. ReadFile(hRead,pBuffer[0],CReadBuffer,dRead,nil);
  514. pBuffer[dRead] := #0;
  515. OemToCharA(pBuffer,dBuffer);
  516. if Assigned(CallBack) then CallBack(dBuffer);
  517. if Assigned(OutputLines) then OutputLines.Add(dBuffer);
  518. until (dRead < CReadBuffer);
  519. end;
  520. //Application.ProcessMessages;
  521. until (dRunning <> WAIT_TIMEOUT);
  522. finally
  523. CloseHandle(piProcess.hProcess);
  524. CloseHandle(piProcess.hThread);
  525. end;
  526. end;
  527. finally
  528. CloseHandle(hRead);
  529. CloseHandle(hWrite);
  530. end;
  531. end
  532. else raise Exception.Create('Can''t create pipe!');
  533. end;
  534. procedure InitConsole;
  535. var
  536. BufferInfo: TConsoleScreenBufferInfo;
  537. begin
  538. Console.LogVerbose := LOG_ALL;
  539. Rewrite(Output);
  540. hStdOut := TTextRec(Output).Handle;
  541. {$IFDEF HASERROUTPUT}
  542. Rewrite(ErrOutput);
  543. hStdErr := TTextRec(ErrOutput).Handle;
  544. {$ELSE}
  545. hStdErr := GetStdHandle(STD_ERROR_HANDLE);
  546. {$ENDIF}
  547. if not GetConsoleScreenBufferInfo(hStdOut, BufferInfo) then
  548. begin
  549. SetInOutRes(GetLastError);
  550. Exit;
  551. end;
  552. ConsoleRect.Left := 0;
  553. ConsoleRect.Top := 0;
  554. ConsoleRect.Right := BufferInfo.dwSize.X - 1;
  555. ConsoleRect.Bottom := BufferInfo.dwSize.Y - 1;
  556. TextAttr := BufferInfo.wAttributes and $FF;
  557. DefConsoleColor := TextAttr;
  558. LastMode := 3; //CO80;
  559. end;
  560. { TConsoleMenu }
  561. procedure TConsoleMenu.AddMenu(const cMenuCaption: string; const cMenuKey: Word; MenuAction: TExecuteProc);
  562. var
  563. conmenu : TConsoleMenuOption;
  564. begin
  565. conmenu.Caption := cMenuCaption;
  566. conmenu.Key := cMenuKey;
  567. conmenu.OnKeyPressed := MenuAction;
  568. fConsoleMenu := fConsoleMenu + [conmenu];
  569. end;
  570. procedure TConsoleMenu.AddMenu(MenuOption: TConsoleMenuOption);
  571. begin
  572. fConsoleMenu := fConsoleMenu + [MenuOption];
  573. end;
  574. constructor TConsoleMenu.Create;
  575. begin
  576. fMenuColor := ccLightCyan;
  577. fIsActive := False;
  578. end;
  579. procedure TConsoleMenu.Refresh(aClearScreen: Boolean);
  580. begin
  581. if aClearScreen then ClearScreen;
  582. WriteMenu;
  583. end;
  584. procedure TConsoleMenu.WaitForKeys;
  585. var
  586. msg: TMsg;
  587. conmenu : TConsoleMenuOption;
  588. keypressed : Word;
  589. begin
  590. fIsActive := True;
  591. HideCursor;
  592. WriteMenu;
  593. while True do
  594. begin
  595. //check key pressed
  596. keypressed := GetConsoleKeyPressed;
  597. for conmenu in fConsoleMenu do
  598. begin
  599. if keypressed = conmenu.Key then
  600. begin
  601. ClearScreen;
  602. WriteMenu;
  603. conmenu.DoKeyPressed;
  604. end;
  605. end;
  606. if keypressed = VK_ESCAPE then
  607. begin
  608. coutXY(50,12,'Exiting...',etInfo);
  609. Exit;
  610. end;
  611. {$ifndef LVCL}
  612. if GetCurrentThreadID=MainThreadID then CheckSynchronize{$ifdef WITHUXTHEME}(1000){$endif} else
  613. {$endif}
  614. WaitMessage;
  615. while PeekMessage(msg,0,0,0,PM_REMOVE) do
  616. begin
  617. if Msg.Message = WM_QUIT then Exit
  618. else
  619. begin
  620. TranslateMessage(Msg);
  621. DispatchMessage(Msg);
  622. end;
  623. end;
  624. end;
  625. ShowCursor;
  626. fIsActive := False;
  627. end;
  628. function GetCharFromVirtualKey(Key: Word): string;
  629. var
  630. keyboardState: TKeyboardState;
  631. asciiResult: Integer;
  632. begin
  633. GetKeyboardState(keyboardState) ;
  634. SetLength(Result, 2) ;
  635. asciiResult := ToAscii(key, MapVirtualKey(key, 0), keyboardState, @Result[1], 0) ;
  636. case asciiResult of
  637. 0: Result := '';
  638. 1: SetLength(Result, 1) ;
  639. 2:;
  640. else
  641. Result := '';
  642. end;
  643. end;
  644. procedure TConsoleMenu.WriteMenu;
  645. var
  646. conmenu : TConsoleMenuOption;
  647. ckey : string;
  648. coord : TCoord;
  649. oldcoord : TCoord;
  650. begin
  651. oldcoord.X := GetCursorX;
  652. oldcoord.Y := GetCursorY;
  653. coord.X := 0;
  654. coord.Y := 0;
  655. SetCursorPos(coord);
  656. TextColor(fMenuColor);
  657. ClearLine(0);
  658. for conmenu in fConsoleMenu do
  659. begin
  660. case conmenu.Key of
  661. VK_F1 : ckey := 'F1';
  662. VK_F2 : ckey := 'F2';
  663. VK_F3 : ckey := 'F3';
  664. VK_F4 : ckey := 'F4';
  665. VK_F5 : ckey := 'F5';
  666. VK_F6 : ckey := 'F6';
  667. VK_F7 : ckey := 'F7';
  668. VK_F8 : ckey := 'F8';
  669. VK_F9 : ckey := 'F9';
  670. VK_F10 : ckey := 'F10';
  671. VK_F11 : ckey := 'F11';
  672. VK_F12 : ckey := 'F12';
  673. else ckey := GetCharFromVirtualKey(conmenu.Key);
  674. end;
  675. TextColor(ccWhite);
  676. Write(Format('[%s]',[ckey]));
  677. TextColor(Self.MenuColor);
  678. Write(Format(' %s ',[conmenu.Caption]));
  679. end;
  680. TextColor(ccWhite);
  681. Write('[ESC]');
  682. TextColor(Self.MenuColor);
  683. Write(' Exit');
  684. TextColor(LastMode);
  685. SetCursorPos(oldcoord);
  686. end;
  687. { TConsoleMenuOption }
  688. procedure TConsoleMenuOption.DoKeyPressed;
  689. begin
  690. if Assigned(fOnKeyPressed) then fOnKeyPressed;
  691. end;
  692. initialization
  693. InitializeCriticalSection(CSConsole);
  694. //init stdout if not a service
  695. if GetStdHandle(STD_OUTPUT_HANDLE) <> 0 then InitConsole;
  696. finalization
  697. DeleteCriticalSection(CSConsole);
  698. end.