Author: DrMungkee XXL
Implementing a console within a windows application without resorting to an
external console application.
Answer:
Consoles are usefull for giving a user access to an application's more complex
features without cluttering the interface. If you've ever coded a windowed console,
you realise the "messiness" of the code involved. This class allows you to forget
about all input/output routines with a few lines of code. The console supports most
of the input/output routines available in console (dos) applications such as
WriteLn, ReadLn, ReadKey, GotoXY and many, many more.
Using it is simple, Create a TConsole variable and pass it the form on witch you
want to display the console. The console's default colors will be the same as the
form's color and font.color.
Simply place a "with Console do begin end;" block and put all your console
application code in it. I've placed an example with a string parser at the end of
the article.
There are also some great features:
cutomizable width/height(in characters), borders
easily load and copy displays with CopyContext and SetContext
user can copy text by dragging the mouse over it like mIRC
user can paste into a read or readln input with CTRL+V
form's properties are adjusted on Create and restored on Free
form's event handler are still processed
and there are some quirks:
you cannot create a TConsole on it's form's OnCreate event
if the form has visible components they will hide the console
you cannot close the form while a read/readln is in progress
read/readln only allow up to 250 chars to avoid glitches
extended characters are not supported for input
text copying with the mouse provides no visual feedback
NOTES
GotoXY,GotoEndOfLine,GetX,GetY,GetLastLine,GetChar,GetText(y:byte), and ClearLn all
refer to x,y coordinates starting at position 1,1 (like in console applications)
TConsole has not been tested with other fonts. If you want to tinker with different
fonts you should set all properties of Canvas.Font (in the Create procedure) and
constants CONSOLE_FONT_HEIGHT, CONSOLE_FONT_WIDTH accordingly.
I was unable to code a suitable visual feedback such as highlighting for the
auto-text-copying feature. The main problem is the TForm.OnMouseMove event is only
called once. Running a loop through the OnMouseDown even did not work either. I
could have implemented the loop in a seperate thread but that seems like overkill.
Besides, I want all TConsole functions suspended until the mouse is released so the
user isn't fumbled by the application changing the displayed text. If anyone knows
how mIRC did it, please email me and I'll add it in.
Here is unit Console.pas
1 (please forgive the broken lines)
2
3 unit Console;
4
5 interface
6 uses Forms, Graphics, SysUtils, ExtCtrls, Classes, Controls, ClipBrd;
7
8 const
9 CONSOLE_WIDTH = 70;
10 CONSOLE_HEIGHT = 25;
11 CONSOLE_CARET_SPEED = 500;
12 CONSOLE_OFFSET_X = 5;
13 CONSOLE_OFFSET_Y = 5;
14 CONSOLE_FONT_HEIGHT = 14;
15 CONSOLE_FONT_WIDTH = 7;
16
17 type
18 TConsoleContext = record
19 Name: string;
20 Lines: array[0..CONSOLE_HEIGHT - 1] of string[CONSOLE_WIDTH];
21 PosX, PosY, CaretPosX, CaretPosY: word;
22 LastKey: char;
23 ShiftKeys: TShiftState;
24 KeyPressed: boolean;
25 ShowCaret: boolean;
26 end;
27 PConsoleContext = ^TConsoleContext;
28
29 TConsole = class
30 constructor Create(AForm: TForm);
31 destructor Destroy; override;
32 private
33 Context: PConsoleContext;
34 Caret: TTimer;
35 Canvas: TCanvas;
36 Form: TForm;
37 Background, Forground: TColor;
38 StartDragX, StartDragY: word;
39 PreviousOnPaint: TNotifyEvent;
40 PreviousOnKeyPress: TKeyPressEvent;
41 PreviousOnMouseDown, PreviousOnMouseUp: TMouseEvent;
42 PreviousWidth, PreviousHeight: word;
43 procedure PaintLine(y: byte);
44 procedure Refresh(Sender: TObject);
45 procedure EraseCaret;
46 procedure PaintCaret;
47 procedure ToggleCaret(Sender: TObject);
48 procedure KeyPress(Sender: TObject; var Key: char);
49 procedure OnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
50 x, y: Integer);
51 procedure OnMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
52 x,
53 y: Integer);
54 public
55 procedure CopyContext(var AContext: TConsoleContext);
56 procedure SetContext(var AContext: TConsoleContext);
57 procedure Update;
58 procedure SetColors(FgColor, BgColor: TColor);
59 procedure GotoXY(x, y: byte);
60 procedure GotoEndOfLine(y: byte);
61 function GetX: byte;
62 function GetY: byte;
63 function GetLastLine: byte;
64 function GetChar(x, y: byte): char;
65 function GetText(y: byte): string;
66 procedure Clear;
67 procedure ClearLn(y: byte);
68 procedure LineFeed;
69 procedure write(Str: string);
70 procedure WriteLn(Str: string);
71 function ReadKey: char;
72 function ReadLength(Len: byte): string;
73 function read: string;
74 function ReadLn: string;
75 function ReadLnLength(Len: byte): string;
76 end;
77
78 implementation
79
80 constructor TConsole.Create(AForm: TForm);
81 begin
82 Form := AForm;
83 Canvas := Form.Canvas;
84 Canvas.Font.Name := 'Courier New';
85 Canvas.Font.Size := 8;
86 Canvas.Font.Height := -11;
87 Canvas.Brush.Color := Form.Color;
88 Canvas.Font.Color := Form.Font.Color;
89
90 Background := Form.Color;
91 Forground := Form.Font.Color;
92 PreviousOnPaint := Form.OnPaint;
93 PreviousOnKeyPress := Form.OnKeyPress;
94 PreviousOnMouseDown := Form.OnMouseDown;
95 PreviousOnMouseUp := Form.OnMouseUp;
96 Form.OnMouseDown := OnMouseDown;
97 Form.OnMouseUp := OnMouseUp;
98
99 GetMem(Context, Sizeof(TConsoleContext));
100
101 PreviousWidth := AForm.ClientWidth;
102 PreviousHeight := AForm.ClientHeight;
103 Form.ClientWidth := (CONSOLE_OFFSET_X * 2) + (CONSOLE_WIDTH * CONSOLE_FONT_WIDTH);
104 Form.ClientHeight := (CONSOLE_OFFSET_Y * 2) + (CONSOLE_HEIGHT *
105 CONSOLE_FONT_HEIGHT);
106 Form.OnPaint := Refresh;
107
108 Caret := TTimer.Create(nil);
109 with Caret do
110 begin
111 Enabled := false;
112 Interval := CONSOLE_CARET_SPEED;
113 OnTimer := ToggleCaret;
114 end;
115 Context^.ShowCaret := false;
116
117 Clear;
118 end;
119
120 destructor TConsole.Destroy;
121 begin
122 Caret.Free;
123 FreeMem(Context);
124 Form.OnPaint := PreviousOnPaint;
125 Form.OnKeyPress := PreviousOnKeyPress;
126 Form.OnMouseDown := PreviousOnMouseDown;
127 Form.OnMouseUp := PreviousOnMouseUp;
128 Form.ClientWidth := PreviousWidth;
129 Form.ClientHeight := PreviousHeight;
130 inherited;
131 end;
132
133 procedure TConsole.PaintLine(y: byte);
134 begin
135 Canvas.FillRect(Rect(CONSOLE_OFFSET_X, CONSOLE_OFFSET_Y + (y *
136 (CONSOLE_FONT_HEIGHT)), CONSOLE_OFFSET_X + (CONSOLE_WIDTH) *
137 (CONSOLE_FONT_WIDTH),
138 CONSOLE_OFFSET_Y + (y * (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT));
139 Canvas.TextOut(CONSOLE_OFFSET_X, CONSOLE_OFFSET_Y + (y * (CONSOLE_FONT_HEIGHT)),
140 Context^.Lines[y]);
141 end;
142
143 procedure TConsole.Refresh(Sender: TObject);
144 var
145 y: byte;
146 begin
147 if (CONSOLE_OFFSET_X <> 0) and (CONSOLE_OFFSET_Y <> 0) then
148 begin
149 Canvas.FillRect(Rect(0, 0, Canvas.ClipRect.Right, CONSOLE_OFFSET_Y));
150 Canvas.FillRect(Rect(0, CONSOLE_OFFSET_Y, CONSOLE_OFFSET_X, CONSOLE_OFFSET_Y +
151 ((CONSOLE_HEIGHT - 1) * (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT));
152 Canvas.FillRect(Rect(0, CONSOLE_OFFSET_Y + ((CONSOLE_HEIGHT - 1) *
153 (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT, Canvas.ClipRect.Right,
154 Canvas.ClipRect.Bottom));
155 Canvas.FillRect(Rect(CONSOLE_OFFSET_X + (CONSOLE_WIDTH) * (CONSOLE_FONT_WIDTH),
156 CONSOLE_OFFSET_Y, Canvas.ClipRect.Right, CONSOLE_OFFSET_Y + ((CONSOLE_HEIGHT
157 - 1)
158 * (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT));
159 end;
160 with Context^ do
161 for y := 0 to CONSOLE_HEIGHT - 1 do
162 PaintLine(y);
163 PaintCaret;
164 if Assigned(PreviousOnPaint) then
165 PreviousOnPaint(Sender);
166 end;
167
168 procedure TConsole.EraseCaret;
169 begin
170 with Context^ do
171 if Length(Lines[CaretPosY]) > CaretPosX then
172 Canvas.TextOut(CONSOLE_OFFSET_X + (CaretPosX * (CONSOLE_FONT_WIDTH)),
173 CONSOLE_OFFSET_Y + (CaretPosY * (CONSOLE_FONT_HEIGHT)), Lines[CaretPosY,
174 CaretPosX + 1])
175 else
176 Canvas.TextOut(CONSOLE_OFFSET_X + (CaretPosX * (CONSOLE_FONT_WIDTH)),
177 CONSOLE_OFFSET_Y + (CaretPosY * (CONSOLE_FONT_HEIGHT)), ' ');
178 end;
179
180 procedure TConsole.PaintCaret;
181 begin
182 with Context^ do
183 begin
184 if Caret.Enabled = false then
185 Exit;
186 if ShowCaret = true then
187 begin
188 if (CaretPosX <> PosX) or (CaretPosY <> PosY) then
189 EraseCaret;
190 Canvas.Brush.Color := Forground;
191 Canvas.FillRect(Rect(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
192 CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)) + 10, CONSOLE_OFFSET_X +
193 (PosX
194 * (CONSOLE_FONT_WIDTH)) + CONSOLE_FONT_WIDTH, CONSOLE_OFFSET_Y + (PosY *
195 (CONSOLE_FONT_HEIGHT)) + 13));
196 Canvas.Brush.Color := Background;
197 CaretPosX := PosX;
198 CaretPosY := PosY;
199 end
200 else
201 EraseCaret;
202 end;
203 end;
204
205 procedure TConsole.ToggleCaret(Sender: TObject);
206 begin
207 with Context^ do
208 ShowCaret := not ShowCaret;
209 PaintCaret;
210 end;
211
212 procedure TConsole.KeyPress(Sender: TObject; var Key: char);
213 begin
214 with Context^ do
215 begin
216 LastKey := Key;
217 KeyPressed := true;
218 end;
219 if Assigned(PreviousOnKeyPress) then
220 PreviousOnKeyPress(Form, Key);
221 end;
222
223 procedure TConsole.OnMouseDown(Sender: TObject; Button: TMouseButton; Shift:
224 TShiftState; x, y: Integer);
225 begin
226 if Button <> mbLeft then
227 Exit;
228 StartDragX := (X - CONSOLE_OFFSET_X) div CONSOLE_FONT_WIDTH;
229 StartDragY := (Y - CONSOLE_OFFSET_Y) div CONSOLE_FONT_HEIGHT;
230 if StartDragX >= CONSOLE_WIDTH then
231 StartDragX := CONSOLE_WIDTH - 1;
232 if StartDragY >= CONSOLE_HEIGHT then
233 StartDragY := CONSOLE_HEIGHT - 1;
234 if Assigned(PreviousOnMouseDown) then
235 PreviousOnMouseDown(Sender, Button, Shift, x, y);
236 end;
237
238 procedure TConsole.OnMouseUp(Sender: TObject; Button: TMouseButton; Shift:
239 TShiftState; x, y: Integer);
240 var
241 EndDragX, EndDragY, Temp: word;
242 Str: string;
243 begin
244 if Button <> mbLeft then
245 Exit;
246 EndDragX := (x - CONSOLE_OFFSET_X) div CONSOLE_FONT_WIDTH;
247 EndDragY := (y - CONSOLE_OFFSET_Y) div CONSOLE_FONT_HEIGHT;
248 if EndDragX >= CONSOLE_WIDTH then
249 EndDragX := CONSOLE_WIDTH - 1;
250 if EndDragY >= CONSOLE_HEIGHT then
251 EndDragY := CONSOLE_HEIGHT - 1;
252 if (StartDragX = EndDragX) and (StartDragY = EndDragY) then
253 Exit;
254 if EndDragY < StartDragY then
255 begin
256 Temp := EndDragX;
257 EndDragX := StartDragX;
258 StartDragX := Temp;
259 Temp := EndDragY;
260 EndDragY := StartDragY;
261 StartDragY := Temp;
262 end
263 else if (EndDragY = StartDragY) and (EndDragX < StartDragX) then
264 begin
265 Temp := EndDragX;
266 EndDragX := StartDragX;
267 StartDragX := Temp;
268 end;
269 Inc(StartDragX, 1);
270 Inc(EndDragX, 1);
271
272 with Context^ do
273 begin
274 if StartDragY = EndDragY then
275 Str := Copy(Lines[StartDragY], StartDragX, EndDragX - StartDragX + 1)
276 else
277 begin
278 Str := Copy(Lines[StartDragY], StartDragX, CONSOLE_WIDTH - StartDragX);
279 if EndDragY - StartDragY > 1 then
280 for y := StartDragY + 1 to EndDragY - 1 do
281 Str := Str + Lines[y];
282 Str := Str + Copy(Lines[EndDragY], 1, EndDragX);
283 end;
284 end;
285 ClipBoard.SetTextBuf(PChar(Str));
286 if Assigned(PreviousOnMouseUp) then
287 PreviousOnMouseUp(Sender, Button, Shift, x, y);
288 end;
289
290 procedure TConsole.CopyContext(var AContext: TConsoleContext);
291 begin
292 Move(Context^, AContext, Sizeof(TConsoleContext));
293 end;
294
295 procedure TConsole.SetContext(var AContext: TConsoleContext);
296 begin
297 Move(AContext, Context^, Sizeof(TConsoleContext));
298 Update;
299 end;
300
301 procedure TConsole.Update;
302 begin
303 Refresh(Form);
304 end;
305
306 procedure TConsole.SetColors(FgColor, BgColor: TColor);
307 begin
308 Forground := FgColor;
309 Background := BgColor;
310 Canvas.Font.Color := FgColor;
311 Canvas.Brush.Color := BgColor;
312 Canvas.FillRect(Canvas.ClipRect);
313 Update;
314 end;
315
316 procedure TConsole.GotoXY(x, y: byte);
317 begin
318 with Context^ do
319 begin
320 if x > CONSOLE_WIDTH then
321 x := CONSOLE_WIDTH
322 else if x = 0 then
323 Inc(x, 1);
324 if y > CONSOLE_HEIGHT then
325 y := CONSOLE_HEIGHT
326 else if y = 0 then
327 Inc(y, 1);
328 PosX := x - 1;
329 PosY := y - 1;
330 end;
331 end;
332
333 procedure TConsole.GotoEndOfLine(y: byte);
334 begin
335 if y > CONSOLE_HEIGHT then
336 y := CONSOLE_HEIGHT
337 else if y = 0 then
338 Inc(y, 1);
339 with Context^ do
340 begin
341 PosY := y - 1;
342 PosX := Length(Lines[PosY]);
343 end;
344 end;
345
346 function TConsole.GetX: byte;
347 begin
348 Result := Context^.PosX + 1;
349 end;
350
351 function TConsole.GetY: byte;
352 begin
353 Result := Context^.PosY + 1;
354 end;
355
356 function TConsole.GetLastLine: byte;
357 begin
358 Result := CONSOLE_HEIGHT;
359 end;
360
361 function TConsole.GetChar(x, y: byte): char;
362 begin
363 with Context^ do
364 begin
365 if (x > CONSOLE_WIDTH) or (x = 0) or (y > CONSOLE_HEIGHT) or (y = 0) then
366 Result := #0
367 else
368 begin
369 Dec(y, 1);
370 if x > Length(Lines[y]) then
371 Result := ' '
372 else
373 Result := Lines[y - 1, x];
374 end;
375 end;
376 end;
377
378 function TConsole.GetText(y: byte): string;
379 begin
380 if (y > CONSOLE_HEIGHT) or (y = 0) then
381 Result := ''
382 else
383 Result := Context^.Lines[y - 1];
384 end;
385
386 procedure TConsole.Clear;
387 var
388 y: byte;
389 begin
390 with Context^ do
391 begin
392 for y := 0 to CONSOLE_HEIGHT - 1 do
393 Lines[y] := '';
394 PosX := 0;
395 PosY := 0;
396 KeyPressed := false;
397 LastKey := #0;
398 Canvas.FillRect(Rect(0, 0, (CONSOLE_OFFSET_X * 2) + (CONSOLE_FONT_WIDTH *
399 CONSOLE_WIDTH), (CONSOLE_OFFSET_Y * 2) + (CONSOLE_FONT_HEIGHT *
400 CONSOLE_HEIGHT)));
401 end;
402 end;
403
404 procedure TConsole.ClearLn(y: byte);
405 begin
406 if y > CONSOLE_HEIGHT then
407 y := CONSOLE_HEIGHT
408 else if y = 0 then
409 Inc(y, 1);
410 Dec(y, 1);
411 with Context^ do
412 begin
413 Canvas.FillRect(Rect(0, CONSOLE_OFFSET_Y + (y * (CONSOLE_FONT_HEIGHT)),
414 (CONSOLE_OFFSET_X * 2) + (CONSOLE_WIDTH - 1) * (CONSOLE_FONT_WIDTH + 1),
415 (CONSOLE_OFFSET_Y * 2) + (y * (CONSOLE_FONT_HEIGHT)) + CONSOLE_FONT_HEIGHT));
416 Lines[y] := '';
417 PosX := 0;
418 PosY := y;
419 end;
420 end;
421
422 procedure TConsole.LineFeed;
423 var
424 y: byte;
425 begin
426 with Context^ do
427 begin
428 PosX := 0;
429 if PosY = CONSOLE_HEIGHT - 1 then
430 begin
431 for y := 0 to CONSOLE_HEIGHT - 2 do
432 Lines[y] := Lines[y + 1];
433 Lines[CONSOLE_HEIGHT - 1] := '';
434 Update;
435 end
436 else
437 Inc(PosY, 1);
438 end;
439 end;
440
441 procedure TConsole.write(Str: string);
442 var
443 StrLen, SubPos, SubLen, y, StartPosY: word;
444 begin
445 with Context^ do
446 begin
447 StartPosY := PosY;
448 StrLen := Length(Str);
449 SubPos := 1;
450 if StrLen + PosX < CONSOLE_WIDTH then
451 begin
452 SetLength(Lines[PosY], PosX + StrLen);
453 Move(Str[1], Lines[PosY, PosX + 1], StrLen);
454 Inc(PosX, StrLen);
455 end
456 else if StrLen + PosX = CONSOLE_WIDTH then
457 begin
458 SetLength(Lines[PosY], CONSOLE_WIDTH);
459 Move(Str[1], Lines[PosY, PosX + 1], StrLen);
460 LineFeed;
461 end
462 else
463 begin
464 SubLen := CONSOLE_WIDTH - Length(Lines[PosY]);
465 repeat
466 if PosX + 1 + SubLen > Length(Lines[PosY]) then
467 SetLength(Lines[PosY], PosX + SubLen);
468 Move(Str[SubPos], Lines[PosY, PosX + 1], SubLen);
469 Inc(SubPos, SubLen);
470 if SubPos < StrLen then
471 begin
472 LineFeed;
473 if (StartPosY <> 0) and (PosY = CONSOLE_HEIGHT - 1) then
474 Dec(StartPosY, 1);
475 end
476 else
477 Inc(PosX, SubLen);
478 SubLen := StrLen - SubPos + 1;
479 if SubLen > CONSOLE_WIDTH then
480 SubLen := CONSOLE_WIDTH;
481 until ((SubLen + Length(Lines[PosY]) <= CONSOLE_WIDTH) and (SubPos >= StrLen))
482 or (SubLen = 0);
483 if SubPos < StrLen then
484 begin
485 SetLength(Lines[PosY], PosX + SubLen);
486 Move(Str[SubPos], Lines[PosY, PosX + 1], SubLen);
487 Inc(PosX, SubLen);
488 end;
489 end;
490 for y := StartPosY to PosY do
491 PaintLine(y);
492 end;
493 end;
494
495 procedure TConsole.WriteLn(Str: string);
496 begin
497 write(Str);
498 LineFeed;
499 end;
500
501 function TConsole.ReadKey: char;
502 begin
503 with Context^ do
504 begin
505 KeyPressed := false;
506 repeat
507 Application.HandleMessage;
508 until KeyPressed = true;
509 Result := LastKey;
510 end;
511 end;
512
513 function TConsole.ReadLength(Len: byte): string;
514 var
515 StartPosX, StartPosY: byte;
516 ClipBoardStr: array[0..255] of char;
517 Key: char;
518 begin
519 with Context^ do
520 begin
521 Form.OnKeyPress := KeyPress;
522 Caret.Enabled := true;
523 StartPosX := PosX;
524 StartPosY := PosY;
525 Result := '';
526 repeat
527 Key := ReadKey;
528 if Key = #8 then
529 begin
530 if PosY > StartPosY then
531 begin
532 if PosX > 0 then
533 begin
534 Dec(PosX, 1);
535 SetLength(Lines[PosY], Length(Lines[PosY]) - 1);
536 SetLength(Result, Length(Result) - 1);
537 Canvas.TextOut(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
538 CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)), ' ');
539 end
540 else
541 begin
542 Lines[PosY] := '';
543 Dec(Posy, 1);
544 PosX := CONSOLE_WIDTH - 1;
545 SetLength(Lines[PosY], CONSOLE_WIDTH - 1);
546 SetLength(Result, Length(Result) - 1);
547 Canvas.TextOut(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
548 CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)), ' ');
549 end;
550 end
551 else if PosX > StartPosX then
552 begin
553 Dec(PosX, 1);
554 SetLength(Lines[PosY], Length(Lines[PosY]) - 1);
555 SetLength(Result, Length(Result) - 1);
556 Canvas.TextOut(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
557 CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)), ' ');
558 end;
559 end
560 else if Key = #22 then
561 begin
562 ClipBoard.GetTextBuf(@ClipBoardStr, Len - Length(Result));
563 Result := Result + StrPas(ClipBoardStr);
564 write(StrPas(ClipBoardStr));
565 end
566 else if (Key <> #13) and (Length(Result) <= Len) and (Key > #31) and (Key <
567 #127)
568 then
569 begin
570 Result := Result + Key;
571 Lines[PosY] := Lines[PosY] + Key;
572 Canvas.TextOut(CONSOLE_OFFSET_X + (PosX * (CONSOLE_FONT_WIDTH)),
573 CONSOLE_OFFSET_Y + (PosY * (CONSOLE_FONT_HEIGHT)), Key);
574 Inc(PosX, 1);
575 if PosX = CONSOLE_WIDTH then
576 begin
577 if StartPosY <> 0 then
578 Dec(StartPosY, 1)
579 else
580 StartPosX := 0;
581 LineFeed;
582 Refresh(Canvas);
583 end;
584 end;
585 PaintCaret;
586 until Key = #13;
587 ShowCaret := false;
588 Caret.Enabled := false;
589 Form.OnKeyPress := PreviousOnKeyPress;
590 end;
591 end;
592
593 function TConsole.read: string;
594 begin
595 Result := ReadLength(250);
596 end;
597
598 function TConsole.ReadLn: string;
599 begin
600 Result := ReadLength(250);
601 LineFeed;
602 end;
603
604 function TConsole.ReadLnLength(Len: byte): string;
605 begin
606 if Len > 250 then
607 Len := 250;
608 Result := ReadLength(Len);
609 LineFeed;
610 end;
611
612 end. //UNIT CONSOLE.PAS FINISHED
613
614 //*************************************************************************
615 //*************************** EXAMPLE ***************************************
616 //*************************************************************************
617
618 //Call: AConsole:=TConsole.Create(Form1); before calling TForm1.CommandPrompt;
619
620 procedure TForm1.CommandPrompt;
621 var
622 Command: string;
623 Parameters: array[0..9] of string;
624 ParameterCount: byte;
625
626 procedure ParseLine(c: string);
627 var
628 i: byte;
629 Param: byte;
630 Brackets: boolean;
631 begin
632 try
633 Brackets := false;
634 Param := 0;
635 for i := 0 to 9 do
636 Parameters[i] := '';
637 for i := 1 to Length(c) do
638 begin
639 if c[i] = '"' then
640 begin
641 Brackets := not Brackets;
642 if Brackets = false then
643 Inc(Param, 1);
644 end
645 else if Brackets = true then
646 Parameters[Param] := Parameters[Param] + c[i]
647 else if (c[i] = ' ') and (c[i - 1] <> ' ') then
648 begin
649 Inc(Param, 1);
650 if Param = 10 then
651 Exit;
652 end
653 else
654 Parameters[Param] := Parameters[Param] + c[i];
655 end;
656 finally
657 ParameterCount := Param + 1;
658 Parameters[0] := LowerCase(Parameters[0]);
659 end;
660 end;
661
662 procedure CommandRun;
663 begin
664 with AConsole do
665 begin
666 if ParameterCount < 2 then
667 begin
668 Writeln('Use: run <path>');
669 Writeln(' ex: run "c:\program files\myprogram.exe"');
670 Writeln('');
671 Exit;
672 end;
673 case WinExec(PChar(Parameters[1]), SW_SHOWNORMAL) of
674 0: Writeln('The system is out of memory or resources.');
675 ERROR_BAD_FORMAT:
676 Writeln('The .EXE file is invalid (non-Win32 .EXE or error in .EXE
677 image).'
678 ERROR_FILE_NOT_FOUND: Writeln('The specified file was not found.');
679 ERROR_PATH_NOT_FOUND: Writeln('The specified path was not found.');
680 end;
681 end;
682 end;
683
684 procedure CommandOpen;
685 begin
686 with AConsole do
687 begin
688 if ParameterCount < 2 then
689 begin
690 Writeln('Use: open <path>');
691 Writeln(' ex: open "c:\my documents\finance.doc"');
692 Writeln('');
693 Exit;
694 end;
695 case ShellExecute(Application.Handle, 'open', PChar(Parameters[1]), nil, nil,
696 SW_NORMAL) of
697 0: Writeln('The operating system is out of memory or resources.');
698 ERROR_FILE_NOT_FOUND: Writeln('The specified file was not found.');
699 ERROR_PATH_NOT_FOUND: Writeln('The specified path was not found.');
700 ERROR_BAD_FORMAT:
701 Writeln('The .EXE file is invalid (non-Win32 .EXE or error in .EXE
702 image).'
703 SE_ERR_ACCESSDENIED:
704 Writeln('The operating system denied access to the specified file.');
705 SE_ERR_ASSOCINCOMPLETE:
706 Writeln('The filename association is incomplete or invalid.');
707 SE_ERR_DDEBUSY:
708 Writeln('The DDE transaction could not be completed because other DDE
709 transactions were being processed.'
710 SE_ERR_DDEFAIL: Writeln('The DDE transaction failed.');
711 SE_ERR_DDETIMEOUT:
712 Writeln('The DDE transaction could not be completed because the request
713 timed out.'
714 SE_ERR_DLLNOTFOUND:
715 Writeln('The specified dynamic-link library was not found.');
716 SE_ERR_NOASSOC:
717 Writeln('There is no application associated with the given filename
718 extension.'
719 SE_ERR_OOM: Writeln('There was not enough memory to complete the
720 operation.'
721 SE_ERR_SHARE: Writeln('A sharing violation occurred.');
722 end;
723 end;
724 end;
725
726 procedure CommandHelp;
727 begin
728 with AConsole do
729 begin
730 Writeln('The following commands are available:');
731 Writeln(' run <path> (starts an application)');
732 Writeln(' open <path> (opens a file with the associated application)');
733 Writeln(' help (displays this message)');
734 Writeln(' exit (ends the console session)');
735 Writeln('');
736 end;
737 end;
738
739 begin
740 with AConsole do
741 begin
742 GotoXY(0, GetLastLine);
743 WriteLn('Welcome to DrMungkee''s demo console.');
744 WriteLn(' Type ''help'' for a list of available commands.');
745 repeat
746 write('>');
747 Command := ReadLn;
748 ParseLine(Command);
749 if Parameters[0] = 'clear' then
750 Clear
751 else if Parameters[0] = 'run' then
752 CommandRun
753 else if Parameters[0] = 'open' then
754 CommandOpen
755 else if Parameters[0] = 'help' then
756 CommandHelp
757 else if Parameters[0] <> 'exit' then
758 begin
759 Writeln('Unknow Command (' + Parameters[0] + ')');
760 end;
761 until Parameters[0] = 'exit';
762 AConsole.Free;
763 end;
764 end;
|
