{******************************************************************************} { } { ConsoleMemo } { } { Component derived from TMemo imitating the behaviour of a console like } { the "DOS-box" } { } { original author: Christian Rehn aka R2C2 } { } { Diese Klasse ist für alle gedacht, die meinen sie nützlich finden } { zu müssen ;-) } { This class is intended for everybody thinking it is useful ;-) } { } {******************************************************************************} //TODO: Command-Historx //TODO: allow WordWrap unit ConsoleMemo_class; interface uses StdCtrls, Classes, Graphics; type TConsoleMemoReadMode = (rmNone, rmString, rmInteger, rmCommand); TCommandEvent = procedure(Sender: TObject; Command: string) of object; TConsoleMemo = class(TMemo) private FMinPos: Integer; FReadComplete: Boolean; FReadMode: TConsoleMemoReadMode; FCommandMode: Boolean; FPrompt: string; FOnCommand: TCommandEvent; procedure SetCommandMode(const Value: Boolean); procedure SetReadOnly(Value: Boolean); procedure SetWordWrap(Value: Boolean); protected procedure KeyPress(var Key: Char); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure Click; override; procedure Change; override; property MinPos: Integer read FMinPos write FMinPos; procedure EnsureCaretPos; virtual; procedure ShowPrompt; virtual; procedure HandleCommand; virtual; public constructor Create(AOwner: TComponent); override; property ReadMode: TConsoleMemoReadMode read FReadMode default rmNone; property Prompt: string read FPrompt write FPrompt; function ReadString: string; virtual; function ReadInt: Integer; virtual; published property ReadOnly write SetReadOnly default True; property Color default clBlack; property WordWrap write SetWordWrap; property CommandMode: Boolean read FCommandMode write SetCommandMode default False; property OnCommand: TCommandEvent read FOnCommand write FOnCommand; end; procedure Register; implementation uses Forms, SysUtils, Windows; procedure Register; begin RegisterComponents('R2C2', [TConsoleMemo]); end; constructor TConsoleMemo.Create(AOwner: TComponent); begin inherited Create(AOwner); ReadOnly := True; FReadComplete := False; FReadMode := rmNone; FCommandMode := False; Color := clBlack; Font.Color := clSilver; Font.Name := 'Courier New'; Font.Size := 10; ScrollBars := ssVertical; WordWrap := False; end; procedure TConsoleMemo.SetCommandMode(const Value: Boolean); begin FCommandMode := Value; if Value then begin FReadMode := rmCommand; inherited ReadOnly := False; ShowPrompt; end else begin FReadMode := rmNone; inherited ReadOnly := True; end; end; procedure TConsoleMemo.SetReadOnly(Value: Boolean); begin inherited ReadOnly := Value; if Value then begin FReadMode := rmNone; FCommandMode := False; end else begin FReadMode := rmCommand; FCommandMode := True; end; end; procedure TConsoleMemo.SetWordWrap(Value: Boolean); begin // "disable" WordWrap, because it doesn't work with OnCommand yet inherited WordWrap := False; end; procedure TConsoleMemo.KeyPress(var Key: Char); begin if (Key = #8) and (SelStart <= FMinPos) then Key := #0; // discard backspace, if this would delete more than allowed inherited KeyPress(Key); if (FReadMode <> rmNone) and (Key = #13) then begin if FReadMode = rmCommand then begin HandleCommand; key := #0; // don't add another line end else begin FReadComplete := True; end; end; if (FReadMode = rmInteger) and ( ((not (Key in ['0'..'9', #8])) and (SelStart > MinPos)) or ((not (Key in ['0'..'9', #8, '-'])) and (SelStart = MinPos)) ) then begin Key := #0; // only accept numbers in integer-mode end; EnsureCaretPos; end; procedure TConsoleMemo.KeyDown(var Key: Word; Shift: TShiftState); begin if (Key in [VK_BACK, VK_LEFT]) and (SelStart <= FMinPos) then Key := 0; // discard backspace, if this would delete more than allowed // handle VK_UP separately, because SelStart isn't updated before EnsureCaretPos: if (Key = VK_UP) then Key := 0; inherited KeyDown(Key, Shift); EnsureCaretPos; end; procedure TConsoleMemo.Click; begin inherited Click; if SelLength = 0 then // selecting text is allowed EnsureCaretPos; end; procedure TConsoleMemo.Change; begin inherited Change; EnsureCaretPos; //TODO: paste --> Int end; function TConsoleMemo.ReadInt: Integer; var s: string; begin FMinPos := SelStart; // maximum editable area FReadComplete := False; ReadOnly := False; FReadMode := rmInteger; while (not FReadComplete) and (not Application.Terminated) do begin Application.ProcessMessages; //TODO: WaitForSingleObject? end; ReadOnly := True; FReadMode := rmNone; s := Trim(Copy(Lines.Text, FMinPos +1, Length(Lines.Text) - FMinPos + 1)); Result := StrToIntDef(s, 0); end; function TConsoleMemo.ReadString: string; var s: string; begin FMinPos := SelStart; // maximum editable area FReadComplete := False; ReadOnly := False; FReadMode := rmString; while (not FReadComplete) and (not Application.Terminated) do begin Application.ProcessMessages; //TODO: WaitForSingleObject? end; ReadOnly := True; FReadMode := rmNone; s := Trim(Copy(Lines.Text, FMinPos+1, Length(Lines.Text) - FMinPos + 1)); Result := s; end; procedure TConsoleMemo.EnsureCaretPos; begin if (FReadMode <> rmNone) and (SelStart < FMinPos) then begin SelStart := FMinPos; end; end; procedure TConsoleMemo.ShowPrompt; function RemoveTraillingCRLF(s: string): string; begin while (Length(s) > 0) and (s[Length(s)] in [#13, #10]) do Delete(s, Length(s), 1); Result := s; end; begin if Lines[Lines.Count -1] <> FPrompt then begin Lines.Add(FPrompt); if FPrompt <> '' then Lines.Text := RemoveTraillingCRLF(Lines.Text); end; end; procedure TConsoleMemo.HandleCommand; function RemovePrompt(s: string): string; begin Result := Trim(Copy(s, Length(FPrompt) +1, Length(s) - Length(FPrompt) -1)); end; begin // add space so that Delphi realizes that there is a new line // otherwhise the last command is executed a second time: Lines.Text := Lines.Text + ' '; if Assigned(FOnCommand) then FOnCommand(Self, RemovePrompt(Lines[Lines.Count -1])); ShowPrompt; FMinPos := SelStart; // maximum editable area end; end.