{ Copyright (C) 2007 Julian Schutsch This source is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This code is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. A copy of the GNU Lesser General Public License is available on the World Wide Web at . You can also obtain it by writing to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. Changelog: 9.27.2007 : Seperation from another Package, first Release under GPL Version 0.1 10.02.2007 : Licence Changed to LGPL Added : History Added : Password Input mode Fixed : Blank Screen when Resizing so that TopLine disappears. Added : Fixed Prompt Description infront of Input, moves along with it Etc : Functions, minor Bugs Missing : FreeLineWidth full support Version 0.2 10.08.2007 : Removed : Fixed Line Width Support, Source now less complex Added : Paste/Copy/Cut Ability, Select with Mouse and Shift/Keys Added : TRTLCriticalsection called FLock to make Writeln/Write Threadsafe Fixed : GTK 1/2 Linux support, several changes to make that work... Removed : LineWidth, can cause Property Loading Errors if used with old Apps ! Workarn : GTK Font height gets 2 added on all plattforms, means, win32 have two extra dots unecessarily, can't solve that ! Fixed : Pos 1/End Key changes Scrollbar (Different GTK behaviour !) Version 0.3 12.06.2008 : Optimized Color String output, still needs testing and PWD Strings are not changed yet. Improvement visible on Win32, but still to slow, any hacks? 17.06.2008 : TColorString changed completly, now using Arrays instead of linked lists 25.06.2008 : Fixed everything for Multispace support Added tabulator behaviour Caret type and Color now customizable Input Selection Colors published Speed improvement using precalculated Sum-Widths for TColorString Lots of minor UTF8 Bugs fixed 26.06.2008 : Escape Codes for some sort of Graphical output (Tables, lines, etc) Better moving Input Bug fixes in MakeInputVisible 27.06.2008 : Add FGraphicCharWidth 28.06.2008 : New Escape Code preprocessor Support for different modes (ANSI color, CmdBox, None(ignore)) 29.06.2008 : FStringBuffer added,Works without WakeMainThread now as well Fixed LineOutAndFill Added AutoFollow Todo : Input Masks Todo : Docu } unit uCmdBox; {$mode objfpc}{$H+} interface uses Classes, SysUtils, ExtCtrls, ComCtrls, Controls, Graphics, Forms, LCLType, LCLIntf, LMessages, LResources, ClipBrd, LCLProc; type TCaretType=(cartLine,cartSubBar,cartBigBar,cartUser); TEscapeCodeType=(esctCmdBox,esctAnsi,esctNone); TEscapeMode=(escmNone,escmOperation,escmData2,escmData1,escmAnsiOperation,escmAnsiSquare); type TCmdBox=class; type TColorstring=class; type EOnCmdBoxInput=Procedure(ACmdBox:TCmdBox;Input:String) of object; type EOnCmdBoxInputChange=Procedure(ACmdBox:TCmdBox;InputData:TColorstring) of object; type { TCmdBox } TCmdBox=class(TCustomControl) public constructor Create(AComponent:TComponent);override; destructor Destroy;override; protected procedure Paint;override; procedure Resize;override; procedure UTF8KeyPress(var Key:TUTF8Char);override; procedure KeyDown(var Key:Word;Shift:TShiftState);override; procedure CreateParams(var Params:TCreateParams);override; procedure CreateWnd;override; procedure WMVScroll(var message: TLMVScroll);message LM_VSCROLL; procedure MouseDown(Button:TMouseButton;Shift:TShiftState;x,y:Integer);override; procedure MouseUp(Button:TMouseButton;Shift:TShiftState;x,y:Integer);override; procedure MouseMove(Shift:TShiftState;x,y:Integer);override; procedure EraseBackground(DC:HDC);override; private FLock : System.TRTLCriticalSection; FCaretTimer : TTimer; FCaretVisible : Boolean; FLineCount : Integer; FLines : array of TColorstring; FLineHeights : array of Integer; FLineHeightSum : array of Integer; FTopLine : Integer; FPageHeight : Integer; FVisibleLines : Integer; FVSBVisible : Boolean; FVSBPos : Integer; FVSBWidth : Integer; FClientWidth : Integer; FClientHeight : Integer; FCaretX : Integer; FOutX,FOutY : Integer; FInputX,FInputY : Integer; FInputPos : Integer; FCharHeight : Integer; FLineOfTopLine : Integer; FVisibleLineCount : Integer; FInput : Boolean; FInputBuffer : TColorstring; FInputVisible : Boolean; FInputMinPos : Integer; FUTF8InputMinPos : Integer; FOnInput : EOnCmdBoxInput; FOnAny : EOnCmdBoxInputChange; FOnInputChange : EOnCmdBoxInputChange; FBackGroundColor : TColor; FCurrentColor : TColor; FCurrentBackGround : TColor; FFont : TFont; FPassWordChar : TUTF8Char; FInputIsPassWord : Boolean; FHistory : Array of TColorstring; FHistoryLength : Integer; FHistoryMax : Integer; FHistoryPos : Integer; FInputColor : TColor; FInputBackground : TColor; FInputSelColor : TColor; FInputSelBackGround : TColor; FMouseDown : Boolean; FSelStart,FSelEnd : Integer; FMouseDownInputPos : Integer; FCurrentString : String; FCaretColor : TColor; FCaretType : TCaretType; FCaretWidth : Integer; FCaretHeight : Integer; FCaretYShift : Integer; FTabWidth : Integer; FGraphicCharWidth : Integer; FEscapeCodeType : TEscapeCodeType; FEscapeMode : TEscapeMode; FEscapeData : String; FStringBuffer : TStringList; FAutoFollow : Boolean; procedure CaretTimerExecute(Sender:TObject); procedure SetLineCount(c:Integer); procedure SetTopLine(Nr:Integer); procedure AdjustScrollBars; function AdjustLineHeight(i:Integer):Integer; procedure MakeInputVisible; procedure MakeOutVisible; procedure SetFont(F:TFont); procedure SetBackGroundColor(c:Tcolor); function GetSystemMetricsGapSize(const Index:Integer):Integer; procedure ScrollBarRange(Which: Integer; aRange,aPage: Integer); procedure ScrollBarPosition(Which,Value:Integer); function UpdateLineHeights:Integer; procedure TranslateScrollBarPosition; procedure ScrollUp; procedure SetHistoryMax(v:Integer); procedure InsertHistory; procedure SetHistoryPos(v:Integer); function GetHistory(i:Integer):string; procedure DeleteHistoryEntry(i:Integer); procedure MakeFirstHistoryEntry(i:Integer); function MoveInputCaretTo(x,y:Integer;chl:Boolean):Boolean; procedure SetSelection(Start,Ende:Integer); procedure LeftSelection(Start,Ende:Integer); procedure RightSelection(Start,Ende:Integer); procedure DeleteSelected; procedure SetOutY(v:Integer); procedure IntWrite; procedure MultiWrite; procedure SetCaretType(ACaretType:TCaretType); procedure SetCaretWidth(AValue:Integer); procedure SetCaretHeight(AValue:Integer); procedure SetCaretYShift(AValue:Integer); procedure SetTabWidth(AValue:Integer); function GetCaretInterval:Integer; procedure SetCaretInterval(AValue:Integer); public function HistoryHas(s:string):Boolean; function HistoryIndexOf(s:string):Integer; procedure ClearHistory; procedure TextColor(C:TColor); procedure TextBackground(C:TColor); procedure TextColors(FC,BC:TColor); procedure Write(s:String); procedure Writeln(s:String); procedure WriteStream(Stream:TStream); procedure Clear; procedure StartRead(DFC,DBC:TColor;const Desc:String;IFC,IBC:TColor); procedure StartReadPassWord(DFC,DBC:TColor;const Desc:String;IFC,IBC:TColor); procedure StopRead; procedure CopyToClipBoard; procedure PasteFromClipBoard; procedure CutToClipBoard; procedure ClearLine; property OutX : Integer read FOutX write FOutX; property OutY : Integer read FOutY write SetOutY; property TopLine : Integer read FTopLine write SetTopLine; property History[i:Integer] : string read GetHistory; property InputPos : Integer read FInputPos write FInputPos; function HistoryCount : Integer; published property Align; property Anchors; property ShowHint; property CaretColor : TColor read FCaretColor write FCaretColor; property CaretType : TCaretType read FCaretType write SetCaretType; property CaretWidth : Integer read FCaretWidth write SetCaretWidth; property CaretHeight : Integer read FCaretHeight write SetCaretHeight; property CaretYShift : Integer read FCaretYShift write SetCaretYShift; property OnInput : EOnCmdBoxInput read FOnInput write FOnInput; property OnInputChange : EOnCmdBoxInputChange read FOnInputChange write FOnInputChange; property OnAny : EOnCmdBoxInputChange read FOnAny write FOnAny; property LineCount : Integer read FLineCount write SetLineCount; property Font : TFont read FFont write SetFont; property BackGroundColor : TColor read FBackgroundColor write SetBackGroundColor; property TabWidth : Integer read FTabWidth write SetTabWidth; property PassWordChar : TUTF8Char read FPassWordChar write FPassWordChar; property HistoryMax : Integer read FHistoryMax write SetHistoryMax; property InputSelColor : TColor read FInputSelColor write FInputSelColor; property InputSelBackGround : TColor read FInputSelBackGround write FInputSelBackGround; property CaretInterval : Integer read GetCaretInterval write SetCaretInterval; property EscapeCodeType : TEscapeCodeType read FEscapeCodeType write FEscapeCodeType; property GraphicalCharacterWidth : Integer read FGraphicCharWidth write FGraphicCharWidth; property AutoFollow : Boolean read FAutoFollow write FAutoFollow; property DoubleBuffered default true; end; type TColorChar=record FChar : TUTF8Char; FCharWidth : Integer; FSumWidth : Integer; FWordStart : Integer; FFrontColor : TColor; FBackColor : TColor; end; type TColorString=class private FChars : array of TColorChar; FSumWidth : Integer; FPassWordStart : Integer; FPassWordChar : TUTF8Char; FTabWidth : Integer; procedure MinimumLength(V:Integer;FC,BC:TColor); procedure MaximumLength(V:Integer); procedure UpdateSum; public constructor Create(AFont:TFont); destructor Destroy;override; procedure Clear; procedure OverWrite(S:String;Pos:Integer;FC,BC:TColor); procedure OverWriteChar(s:TUTF8Char;Pos,ADefWidth:Integer;FC,BC:TColor); procedure OverWrite(S:TColorstring;Pos:Integer); procedure OverWritePW(S:TColorstring;PWS,Pos:Integer;PWC:String); procedure PartOverWrite(S:TColorstring;Start,Ende,Pos:Integer); procedure LineOutAndFill(ACanvas:TCanvas;AX,AY,ALeftX,AWrapWidth,ACH,ACB,ACaretPos:Integer;ABC,ACC:TColor;ACaretHeight,ACaretWidth,ACaretYShift:Integer;ADrawCaret:Boolean); function Getstring:String; function GetPartstring(Start,Ende:Integer):String; procedure Delete(Index:Integer); procedure Delete(Index,Len:Integer); procedure Insert(Index:Integer;C:String;FC,BC:TColor); procedure BColorBlock(StartPos,EndPos:Integer;C:TColor); procedure ColorBlock(StartPos,EndPos:Integer;FC,BC:TColor); function LineCount(AWrapWidth,ACaretPos,ACaretWidth:Integer):Integer; function GetLength:Integer; function GetLineOfCaret(AWrapWidth,ACaretPos,ACaretWidth:Integer):Integer; function GetCharPosition(AWrapWidth,ALine,AXPos:Integer):Integer; private FFont : TFont; FDefaultBackGround : TColor; public property TabWidth : Integer read FTabWidth write FTabWidth; property PassWordChar : TUTF8Char read FPassWordChar write FPassWordChar; property PassWordStart : Integer read FPassWordStart write FPassWordStart; property Length : Integer read GetLength; property DefaultBackGround : TColor read FDefaultBackground write FDefaultBackground; property Font : TFont read FFont write FFont; end; procedure Register; implementation procedure TColorString.UpdateSum; var i : Integer; LastWordStart : Integer; SumWidth : Integer; begin LastWordStart := 0; SumWidth := 0; for i:=0 to High(FChars) do begin with FChars[i] do begin FWordStart := LastWordStart; case FChar[1] of #9: begin FCharWidth := (SumWidth div FTabWidth+1)*FTabWidth-SumWidth; LastWordStart := i+1; end; #27: begin case FChar[2] of #9: begin FCharWidth := (SumWidth div FTabWidth+1)*FTabWidth-SumWidth; LastWordStart := i+1; end; #10:LastWordStart:=i+1; #32,#46,#196,#205: begin FCharWidth := Ord(FChar[3]); LastWordStart := i+1; end; #33,#47,#197,#206: begin FCharWidth := (Ord(FChar[3])+Ord(FChar[4])*256)-SumWidth; if FCharWidth<0 then FCharWidth:=0; LastWordStart := i+1; end; end; end; else if FChar=' ' then LastWordStart:=i+1; end; SumWidth := SumWidth+FCharWidth; FSumWidth := SumWidth; end; end; FSumWidth:=SumWidth; end; function TColorString.GetLength:Integer; begin Result:=System.Length(FChars); end; procedure TCmdBox.SetTabWidth(AValue:Integer); var i:Integer; begin FTabWidth:=AValue; for i:=0 to FLineCount-1 do FLines[i].TabWidth:=AValue; UpdateLineHeights; Invalidate; end; procedure TCmdBox.SetCaretWidth(AValue:Integer); begin FCaretWidth := AValue; FCaretType := cartUser; end; procedure TCmdBox.SetCaretHeight(AValue:Integer); begin FCaretHeight := AValue; FCaretType := cartUser; end; procedure TCmdBox.SetCaretYShift(AValue:Integer); begin FCaretYShift := AValue; FCaretType := cartUser; end; procedure TCmdBox.SetCaretType(ACaretType:TCaretType); begin case ACaretType of cartLine: begin if HandleAllocated then FCaretHeight:=FFont.GetTextHeight('A')-3 else FCaretHeight:=-1; FCaretWidth := 1; FCaretYShift := 3; end; cartSubBar: begin FCaretWidth := -1; FCaretHeight := 3; FCaretYShift := 0; end; cartBigBar: begin if HandleAllocated then FCaretHeight:=FFont.GetTextHeight('A')-3 else FCaretHeight:=-1; FCaretWidth := -1; FCaretYShift := 3; end; end; Invalidate; FCaretType:=ACaretType; end; // TOdo : Use string buffer instead of string (speed improvement expected) procedure TColorString.LineOutAndFill(ACanvas:TCanvas;AX,AY,ALeftX,AWrapWidth,ACH,ACB,ACaretPos:Integer;ABC,ACC:TColor;ACaretHeight,ACaretWidth,ACaretYShift:Integer;ADrawCaret:Boolean); var LineStart : Integer; LineEnd : Integer; MidWidth : Integer; LineStartSumWidth : Integer; x : Integer; LastLineSumWidth : Integer; ACHH : Integer; ACBH : Integer; procedure DrawLine; var SameColor : String; SameForeColor : TColor; SameBackColor : TColor; SameColorX : Integer; SameColorWidth : Integer; LP : Integer; CaretX : Integer; CaretW : Integer; CW : Integer; xp : Integer; begin if (AY<=-ACH) and (AY>ACanvas.Height) then begin Inc(AY,ACH); Ax:=ALeftx; Exit; end; SameColor:=''; ACanvas.Brush.Style:=bsSolid; // TODO: Please try to reproduce this Ultra-Shit Error which couples GetTextWidth input to // TextOut Output. I can't solve this...i am not Stupid Enough for such errors! // (Is in bug report, should be fixed somewhere in the future!) ACanvas.Font.GetTextWidth('%%%_$%_Hallo\\\\\\\\\32489738'); // End of shit LP := LineStart; CaretX := -1; while LineStart<>LineEnd+1 do begin with FChars[LineStart] do begin CW:=FCharWidth; if FChar=#9 then begin if SameColor<>'' then begin ACanvas.Font.Color :=SameForeColor; ACanvas.Brush.Color :=SameBackColor; ACanvas.FillRect(SameColorX,AY,SameColorX+SameColorWidth,Ay+ACH); ACanvas.TextOut(SameColorX,AY,SameColor); Inc(SameColorX,SameColorWidth); SameColor:=''; end else SameColorX:=AX; ACanvas.Brush.Color:=FBackColor; ACanvas.Fillrect(SameColorX,AY,SameColorX+FCharWidth,AY+ACH); end else if FChar[1]=#27 then begin if SameColor<>'' then begin ACanvas.Font.Color :=SameForeColor; ACanvas.Brush.Color :=SameBackColor; ACanvas.FillRect(SameColorX,AY,SameColorX+SameColorWidth,Ay+ACH); ACanvas.TextOut(SameColorX,AY,SameColor); Inc(SameColorX,SameColorWidth); SameColor:=''; end else SameColorX:=AX; case FChar[2] of #9: begin case FChar[3] of #46: begin ACanvas.Pen.Color:=FFrontColor; ACanvas.Pen.Style:=psDash; ACanvas.Brush.Color:=FBackColor; ACanvas.Fillrect(SameColorX,AY,SameColorX+FCharWidth,AY+ACH); xp:=SameColorX; if xp mod 2<>0 then Inc(xp); while xp0 then Inc(xp); while xp=FPassWordStart) then begin SameColor := FPassWordChar; SameColorWidth := FFont.GetTextWidth(FPassWordChar); end else begin SameColor := FChar; SameColorWidth := FCharWidth; end; SameColorX := AX; SameForeColor := FFrontColor; SameBackColor := FBackColor; end else begin if (SameForeColor=FFrontColor) and (SameBackColor=FBackColor) then begin if (LP>=FPassWordStart) then begin SameColor:=SameColor+FPassWordChar; Inc(SameColorWidth,FFont.GetTextWidth(FPassWordChar)); end else begin SameColor:=SameColor+FChar; Inc(SameColorWidth,FCharWidth); end; end else begin ACanvas.Font.Color :=SameForeColor; ACanvas.Brush.Color :=SameBackColor; ACanvas.FillRect(SameColorX,Ay,SameColorX+SameColorWidth,Ay+ACH); ACanvas.TextOut(SameColorX,AY,SameColor); if (LP>=FPassWordStart) then begin SameColor := FPassWordChar; SameColorWidth := FFont.GetTextWidth(FPassWordChar); end else begin SameColor := FChar; SameColorWidth := FCharWidth; end; SameForeColor := FFrontColor; SameBackColor := FBackColor; SameColorX := AX; end; end; if LP=ACaretPos then begin CaretX:=AX; CaretW:=FCharWidth; end; Inc(AX,CW); Inc(LP); end; Inc(LineStart); end; if SameColor<>'' then begin ACanvas.Font.Color := SameForeColor; ACanvas.Brush.Color := SameBackColor; ACanvas.FillRect(SameColorX,Ay,SameColorX+SameColorWidth,Ay+ACH); ACanvas.TextOut(SameColorX,AY,SameColor); end; ACanvas.FillRect(AX,AY,AWrapWidth,AY+ACH); AX:=ALeftX; Inc(AY,ACH); if ADrawCaret and (CaretX>=0) then begin ACanvas.Brush.Color:=ACC; if ACaretWidth>=0 then CaretW:=ACaretWidth; ACanvas.FillRect(CaretX,AY-ACaretHeight-ACaretYShift,CaretX+CaretW,AY-ACaretYShift); end; end; begin if AWrapWidth<0 then AWrapWidth:=0; if System.Length(FChars)=0 then begin ACanvas.Brush.Style := bsSolid; ACanvas.Brush.Color := ABC; ACanvas.FillRect(AX,AY,AWrapWidth,AY+ACH); Exit; end; ACHH := ACH div 2; ACBH := ACB div 2; MidWidth := FSumWidth div System.Length(FChars); LineStart := 0; LineStartSumWidth := 0; LastLineSumWidth := 0; x := 0; while LineStartHigh(FChars) then x:=High(FChars); while (xLineStart) and (FChars[x].FSumWidth-LineStartSumWidth>=AWrapWidth) do with FChars[x] do if (FChar<>' ') and (FWordStart>LineStart) then x:=FWordStart-1 else Dec(x); LineEnd:=x; DrawLine; LastLineSumWidth := LineStartSumWidth; LineStartSumWidth := FChars[x].FSumWidth; LineStart := x+1; end; if ACaretPos>=LineStart then begin if ACaretWidth>=0 then x:=ACaretWidth else x:=FFont.GetTextWidth('A'); AX:=LineStartSumWidth-LastLineSumWidth+(ACaretPos-LineStart)*x; if Ax+x>AWrapWidth then begin Ax:=0; ACanvas.Brush.Color:=ABC; ACanvas.FillRect(0,AY,AWrapWidth,AY+ACH); Inc(Ay,ACH); end; if ADrawCaret then begin ACanvas.Brush.Color:=ACC; ACanvas.FillRect(AX,AY-ACaretHeight-ACaretYShift,AX+x,AY-ACaretYShift); end; end; end; function TColorString.GetCharPosition(AWrapWidth,ALine,AXPos:Integer):Integer; var x,MidWidth,LineStart,LineStartSumWidth,LastLineSumWidth,LastLineStart:Integer; begin if AWrapWidth<0 then AWrapWidth:=0; if System.Length(FChars)=0 then begin Result:=0; Exit; end; MidWidth := FSumWidth div System.Length(FChars); if MidWidth=0 then begin Result:=0; Exit; end; LineStart := 0; LineStartSumWidth := 0; LastLineSumWidth := 0; x:=0; while (LineStart=0) do begin x:=LineStart+AWrapWidth div MidWidth; if x>High(FChars) then x:=High(FChars); while (xLineStart) and (FChars[x].FSumWidth-LineStartSumWidth>=AWrapWidth) do with FChars[x] do if (FChar<>' ') and (FWordStart>LineStart) then x:=FWordStart-1 else Dec(x); LastLineSumWidth := LineStartSumWidth; LineStartSumWidth := FChars[x].FSumWidth; LastLineStart := LineStart; LineStart := x+1; Dec(ALine); end; Result:=LastLineStart; while (ResultHigh(FChars) then x:=High(FChars); while (xLineStart) and (FChars[x].FSumWidth-LineStartSumWidth>=AWrapWidth) do with FChars[x] do if (FChar<>' ') and (FWordStart>LineStart) then x:=FWordStart-1 else Dec(x); LastLineSumWidth := LineStartSumWidth; LineStartSumWidth := FChars[x].FSumWidth; LineStart := x+1; if ACaretPos=0 then x:=ACaretWidth else x:=FFont.GetTextWidth('A'); if (ACaretPos>LineStart) or (LineStartSumWidth-LastLineSumWidth+(ACaretPos-LineStart)*x+x<=AWrapWidth) then Dec(Result); end; function TColorString.LineCount(AWrapWidth,ACaretPos,ACaretWidth:Integer):Integer; var x : Integer; MidWidth : Integer; LineStart : Integer; LineStartSumWidth : Integer; LastLineSumWidth : Integer; begin if AWrapWidth<0 then AWrapWidth:=0; if System.Length(FChars)=0 then begin Result:=1; Exit; end; MidWidth := FSumWidth div System.Length(FChars); if MidWidth=0 then begin Result:=1; Exit; end; LineStart := 0; LineStartSumWidth := 0; LastLineSumWidth := 0; Result:=0; x:=0; while LineStartHigh(FChars) then x:=High(FChars); while (xLineStart) and (FChars[x].FSumWidth-LineStartSumWidth>=AWrapWidth) do with FChars[x] do if (FChar<>' ') and (FWordStart>LineStart) then x:=FWordStart-1 else Dec(x); LastLineSumWidth := LineStartSumWidth; LineStartSumWidth := FChars[x].FSumWidth; LineStart := x+1; Inc(Result); end; if ACaretWidth>=0 then x:=ACaretWidth else x:=FFont.GetTextWidth('A'); if (ACaretPos>=LineStart) and (LineStartSumWidth-LastLineSumWidth+(ACaretPos-LineStart)*x+x>AWrapWidth) then Inc(Result); end; constructor TColorString.Create(AFont:TFont); begin inherited Create; FTabWidth := 1; FFont := AFont; FPassWordStart := MaxInt; end; procedure TColorstring.BColorBlock(StartPos,EndPos:Integer;C:TColor); var i:Integer; begin if StartPos<0 then StartPos:=0; if EndPos>High(FChars) then EndPos:=High(FChars); for i:=StartPos to EndPos do FChars[i].FBackColor:=C; end; procedure TColorstring.ColorBlock(StartPos,EndPos:Integer;FC,BC:TColor); var i:Integer; begin if StartPos<0 then StartPos:=0; if EndPos>High(FChars) then EndPos:=High(FChars); for i:=StartPos to EndPos do begin FChars[i].FFrontColor := FC; FChars[i].FBackColor := BC; end; end; procedure TColorstring.Insert(Index:Integer;C:string;FC,BC:TColor); var i : Integer; l : Integer; Pp : Integer; OldLen : Integer; SLen : Integer; begin OldLen := System.Length(FChars); SLen := UTF8Length(C); if OldLen=FPassWordStart then FCharWidth:=FFont.GetTextWidth(FPassWordChar) else FCharWidth:=FFont.GetTextWidth(FChar); FFrontColor := FC; FBackColor := BC; end; Inc(pp,l); end; UpdateSum; end; procedure TColorstring.Delete(Index,Len:Integer); var i:Integer; begin if (Len=0) or (Index>=System.Length(FChars)) then Exit; if Index+Len>System.Length(FChars) then Len:=System.Length(FChars)-Index; for i:=Index to System.Length(FChars)-Len-1 do FChars[i]:=FChars[i+Len]; SetLength(FChars,System.Length(FChars)-Len); UpdateSum; end; procedure TColorstring.Delete(Index:Integer); var i:Integer; begin if (Index>=System.Length(FChars)) then Exit; for i:=Index to System.Length(FChars)-2 do FChars[i]:=FChars[i+1]; SetLength(FChars,System.Length(FChars)-1); UpdateSum; end; function TColorstring.GetPartstring(Start,Ende:Integer):string; var i,n : Integer; Len : Integer; begin if Start<0 then Start:=0; if Ende>High(FChars) then Ende:=High(FChars); Len:=0; for i:=Start to Ende do Inc(Len,System.Length(FChars[i].FChar)); SetLength(Result,Len); Len:=1; for i:=Start to Ende do begin with FChars[i] do begin for n:=1 to System.Length(FChar) do begin Result[Len]:=FChar[n]; Inc(Len); end; end; end; end; function TColorstring.Getstring:String; var i,n : Integer; Len : Integer; begin Len := 0; for i:=0 to High(FChars) do Inc(Len,System.Length(FChars[i].FChar)); SetLength(Result,Len); Len := 1; for i:=0 to High(FChars) do begin with FChars[i] do begin for n:=1 to System.Length(FChar) do begin Result[Len]:=FChar[n]; Inc(Len); end; end; end; end; procedure TColorstring.OverWritePW(S:TColorstring;PWS,Pos:Integer;PWC:String); var i : Integer; CPassWordStart:Integer; begin MinimumLength(Pos+S.Length,CLSilver,S.FDefaultBackGround); CPassWordStart:=PWS; for i:=0 to S.Length-1 do begin FChars[i+Pos]:=S.FChars[i]; if CPassWordStart<=0 then FChars[i+Pos].FChar:=PWC; Dec(CPassWordStart); end; UpdateSum; end; procedure TColorstring.OverWrite(S:TColorstring;Pos:Integer); var i : Integer; begin MinimumLength(Pos+S.Length,CLSilver,S.FDefaultBackGround); for i:=0 to S.Length-1 do FChars[i+Pos]:=S.FChars[i]; UpdateSum; end; procedure TColorstring.PartOverWrite(S:TColorstring;Start,Ende,Pos:Integer); var i : Integer; begin MinimumLength(Pos+Ende-Start,CLSilver,S.FDefaultBackGround); for i:=0 to Ende-Start-1 do FChars[i+Pos]:=S.FChars[i+Start]; UpdateSum; end; procedure TColorstring.OverWrite(s:String;Pos:Integer;FC,BC:TColor); var i,Pp,l : Integer; begin MinimumLength(Pos+UTF8Length(S),FC,BC); Pp:=1; for i:=0 to UTF8Length(S)-1 do begin l:=UTF8CharacterLength(@s[Pp]); with FChars[i+Pos] do begin FChar := Copy(S,Pp,l); FCharWidth := FFont.GetTextWidth(FChar); FFrontColor := FC; FBackColor := BC; end; Inc(Pp,l); end; UpdateSum; end; procedure TColorstring.OverWriteChar(s:TUTF8Char;Pos,ADefWidth:Integer;FC,BC:TColor); begin MinimumLength(Pos+1,FC,BC); with FChars[Pos] do begin FChar := s; FCharWidth := ADefWidth; FFrontColor := FC; FBackColor := BC; end; UpdateSum; end; procedure TColorstring.MinimumLength(V:Integer;FC,BC:TColor); var OldLen,i:Integer; begin if System.Length(FChars)V then SetLength(FChars,V); end; procedure TColorstring.Clear; begin FChars:=Nil; end; procedure TCmdBox.ClearLine; begin if FLines[FOutY].Length<>0 then begin FLines[FOutY].Clear; FOutX:=0; if FInput then FInputY:=FOutY; Invalidate; end; end; function TCmdBox.GetCaretInterval:Integer; begin Result:=FCaretTimer.Interval; end; procedure TCmdBox.SetCaretInterval(AValue:Integer); begin FCaretTimer.Interval:=AValue; end; procedure TCmdBox.MultiWrite; var DoWrite:Boolean; begin System.EnterCriticalSection(FLock); DoWrite:=FStringBuffer.Count<>0; if DoWrite then begin FCurrentString:=FStringBuffer[0]; FStringBuffer.Delete(0); end; System.LeaveCriticalSection(FLock); if DoWrite then IntWrite; end; procedure TCmdBox.Write(S:String); begin if ThreadID=MainThreadId then begin MultiWrite; FCurrentString:=S; IntWrite; end else begin System.EnterCriticalSection(FLock); FStringBuffer.Add(S); System.LeaveCriticalSection(FLock); if Assigned(WakeMainThread) then TThread.Synchronize(Nil,@MultiWrite); end; end; function TCmdBox.HistoryIndexOf(s:string):Integer; begin for Result:=0 to HistoryCount-1 do if History[Result]=s then Exit; Result:=-1; end; function TCmdBox.HistoryHas(s:string):Boolean; var i:Integer; begin Result := True; for i:=0 to HistoryCount-1 do if History[i]=s then Exit; Result := False; end; function TCmdBox.HistoryCount:Integer; begin HistoryCount:=FHistoryLength-Ord(FInput); end; function TCmdBox.GetHistory(i:Integer):string; begin Inc(i,Ord(FInput)); if (i>=0) and (iFHistoryMax then begin if FHistoryLength>v then FHistoryLength:=v; for i:=v to FHistoryMax-1 do FHistory[i].Free; SetLength(FHistory,v); for i:=FHistoryMax to v-1 do FHistory[i]:=TColorstring.Create(Canvas.Font); FHistoryMax:=v; end; end; procedure TCmdBox.WriteStream(Stream:TStream); var c:wideString; begin while Stream.Position-1 then FInputBuffer.ColorBlock(FSelStart,FSelEnd,FInputColor,FInputBackGround); if Start=Ende then FSelStart:=-1 else begin if Start-1 then FInputBuffer.ColorBlock(FSelStart,FSelEnd,FInputSelColor,FInputSelBackGround); end; procedure TCmdBox.CopyToClipBoard; begin if FSelStart<>-1 then begin ClipBoard.AsText:=FInputBuffer.GetPartstring(FSelStart,FSelEnd); end; end; procedure TCmdBox.PasteFromClipBoard; var s:widestring; l,Pp:Integer; begin if ClipBoard.HasFormat(CF_TEXT) then begin s := ClipBoard.AsText; Pp := 1; while pp<=Length(s) do begin l := UTF8CharacterLength(@S[Pp]); if (l=1) and (Byte(S[Pp])<32) then Delete(s,Pp,1) else inc(Pp,l); end; FInputBuffer.Insert(InputPos,s,FInputColor,FInputBackGround); InputPos := InputPos + UTF8Length(s); FCaretX:=FInputX+InputPos; AdjustScrollBars; MakeInputVisible; FHistoryPos:=0; if Assigned(FOnInputChange) then FOnInputChange(Self,FInputBuffer); if Assigned(FOnAny) then FOnAny(Self,FInputBuffer); end; end; procedure TCmdBox.DeleteSelected; begin if FSelStart<>-1 then begin FInputBuffer.Delete(FSelStart,FSelEnd-FSelStart+1); FInputPos := FSelStart; FCaretX := FInputX+FInputPos; FSelStart := -1; end; end; procedure TCmdBox.CutToClipBoard; begin if FSelStart<>-1 then begin ClipBoard.AsText:=FInputBuffer.GetPartstring(FSelStart,FSelEnd); DeleteSelected; end; end; procedure TCmdBox.MouseMove(Shift:TShiftState;x,y:Integer); begin if FMouseDown then begin if MoveInputCaretTo(x,y,false) then SetSelection(FMouseDownInputPos,FInputPos); end; end; function TCmdBox.MoveInputCaretTo(x,y:Integer;chl:Boolean):Boolean; var h,sl,q:Integer; begin if not FInput then Exit; y := y div FCharHeight; h := FLineHeightSum[FTopLine]+FLineOfTopLine+y; sl := FTopLine; while (slFInputBuffer.Length) then q:=FInputBuffer.Length-FInputX; FCaretX := q; FInputPos := FCaretX-FInputX; if Assigned(FOnAny) then FOnAny(Self,FInputBuffer); Invalidate; Result:=True; end else Result:=False; end; procedure TCmdBox.MouseDown(Button:TMouseButton;Shift:TShiftState;x,y:Integer); begin SetFocus; MoveInputCaretTo(x,y,True); FMouseDown:=True; SetSelection(-1,0); FMouseDownInputPos:=FInputPos; Invalidate; end; procedure TCmdBox.MouseUp(Button:TMouseButton;Shift:TShiftState;x,y:Integer); begin FMouseDown:=False; end; destructor TColorstring.Destroy; begin Clear; inherited Destroy; end; procedure TCmdBox.ScrollUp; var n:Integer; Firstwidestring : TColorstring; begin Firstwidestring:=FLines[0]; for n:=0 to Length(FLines)-2 do Flines[n] := FLines[n+1]; Firstwidestring.Clear; Firstwidestring.FDefaultBackGround := FBackGroundColor; Flines[High(Flines)]:=Firstwidestring; end; procedure TCmdBox.TextColors(FC,BC:TColor); begin FCurrentColor := FC; FCurrentBackGround := BC; end; procedure TCmdBox.TextColor(C:TColor); begin FCurrentColor:=C; end; procedure TCmdBox.TextBackGround(C:TColor); begin FCurrentBackGround:=C; end; procedure TCmdBox.TranslateScrollBarPosition; var GLine,Line : Integer; He :Integer; begin if (FLineOfTopLineFVisibleLineCount-FPageHeight then CurrentPos:=FVisibleLineCount-FPageHeight; {$IFNDEF LCLGTK} ScrollBarPosition(SB_VERT, CurrentPos); {$ENDIF} FVSBPos:=CurrentPos; TranslateScrollBarPosition; end; procedure TCmdBox.ScrollBarRange(Which: Integer; aRange,aPage: Integer); var ScrollInfo: TScrollInfo; begin if HandleAllocated then begin FillChar(ScrollInfo, SizeOf(ScrollInfo), 0); ScrollInfo.cbSize := SizeOf(ScrollInfo); ScrollInfo.fMask := SIF_RANGE or SIF_PAGE or SIF_DISABLENOSCROLL; // Dont't know, someone told me to kick it...so i did:P // {$ifdef Unix} { ScrollInfo.fMask := ScrollInfo.fMask or SIF_UPDATEPOLICY; if goThumbTracking in Options then ScrollInfo.ntrackPos := SB_POLICY_CONTINUOUS else ScrollInfo.ntrackPos := SB_POLICY_DISCONTINUOUS;} // {$endif}} ScrollInfo.nMin := 0; ScrollInfo.nMax := ARange; if APage<0 then APage := 0; ScrollInfo.nPage := APage; SetScrollInfo(Handle, Which, ScrollInfo, True); end; end; procedure TCmdBox.ScrollBarPosition(Which, Value: integer); var ScrollInfo : TScrollInfo; Vis : Boolean; begin if HandleAllocated then begin if Which = SB_VERT then Vis := FVSbVisible else FillChar(ScrollInfo, SizeOf(ScrollInfo), 0); ScrollInfo.cbSize := SizeOf(ScrollInfo); ScrollInfo.fMask := SIF_POS; ScrollInfo.nPos := Value; SetScrollInfo(Handle, Which, ScrollInfo, Vis); end; end; function TCmdBox.GetSystemMetricsGapSize(const Index:Integer):Integer; begin {$ifdef LCLWIN32} result:=0; {$else} result:=3; {$endif} end; procedure TCmdBox.SetBackGroundColor(c:TColor); begin if c<>FBackGroundColor then begin FBackGroundColor:=c; Invalidate; end; end; procedure TCmdBox.SetFont(F:TFont); var DC : HDC; Save : THandle; Metrics : TTextMetric; begin FFont.Assign(F); Canvas.Font := FFont; DC := GetDC(0); Save := SelectObject(DC,FFont.Handle); GetTextMetrics(DC, Metrics); SelectObject(DC, Save); ReleaseDC(0, DC); FCharHeight := Abs(Metrics.tmHeight)+2; Invalidate; end; // Still a Bug: Try having a cmdline with more lines than fit on screen : update doesn't work anymore... procedure TCmdBox.MakeInputVisible; var y : Integer; begin if not FAutoFollow then Exit; UpdateLineHeights; y:=FLineHeightSum[FInputY]+FInputBuffer.GetLineOfCaret(FClientWidth,FCaretX,FCaretWidth); if y>=FLineHeightSum[FTopLine]+FLineOfTopLine+FPageHeight then begin While y>=FLineHeightSum[FTopLine]+FLineHeights[FTopLine]+FPageHeight-1 do Inc(FTopLine); FLineOfTopLine:=y-(FLineHeightSum[FTopLine]+FPageHeight)+1; end else if yFVSBPos then begin FVSBPos:=y; if HandleAllocated then ScrollBarPosition(SB_Vert,y); end; end; procedure TCmdBox.MakeOutVisible; var y : Integer; begin if not FAutoFollow then Exit; UpdateLineHeights; y:=FLineHeightSum[FOutY]+FLines[FOutY].GetLineOfCaret(FClientWidth,FOutX,FCaretWidth); if y>=FLineHeightSum[FTopLine]+FLineOfTopLine+FPageHeight then begin While y>=FLineHeightSum[FTopLine]+FLineHeights[FTopLine]+FPageHeight-1 do Inc(FTopLine); FLineOfTopLine:=y-(FLineHeightSum[FTopLine]+FPageHeight)+1; end else if yFVSBPos then begin FVSBPos:=y; if HandleAllocated then ScrollBarPosition(SB_Vert,y); end; end; procedure TCmdBox.SetHistoryPos(v:Integer); begin if FInputIsPassWord then Exit; if v<0 then v:=FHistoryLength-1 else if v>=FHistoryLength then v:=0; if v<>FHistoryPos then begin if FHistoryPos=0 then begin FHistory[0].Clear; FHistory[0].PartOverWrite(FInputBuffer,FInputMinPos,FInputBuffer.Length,0); end; FInputBuffer.MaximumLength(FInputMinPos+FHistory[v].Length); FInputBuffer.OverWrite(FHistory[v],FInputMinPos); if FInputPos>FInputBuffer.Length then begin FInputPos:=FInputBuffer.Length; FCaretX:=FInputX+FInputPos; end; FHistoryPos:=v; end; if Assigned(FOnInputChange) then FOnInputChange(Self,FInputBuffer); MakeInputVisible; AdjustLineHeight(FInputY); AdjustScrollBars; Invalidate; end; procedure TCmdBox.UTF8KeyPress(var Key:TUTF8Char); begin if not FInput then Exit; if key>=#32 then begin if FSelStart<>-1 then DeleteSelected; FInputBuffer.Insert(FInputPos,key,FInputColor,FInputBackGround); Inc(FInputPos); FCaretX:=FInputX+FInputPos; FHistoryPos:=0; if assigned(FOnInputChange) then FOnInputChange(Self,FInputBuffer); end; if Assigned(OnAny) then OnAny(Self,FInputBuffer); AdjustScrollBars; MakeInputVisible; If FInputVisible then Invalidate; end; procedure TCmdBox.KeyDown(var Key:Word;Shift:TShiftState); var s : String; i : Integer; begin if not FInput then Exit; case Key of VK_END: begin key:=0; if (not (ssAlt in Shift)) and FInput and (FInputPos<>FInputBuffer.Length) then begin if not (ssShift in Shift) then SetSelection(-1,0) else RightSelection(FInputPos,FInputBuffer.Length); FInputPos:=FInputBuffer.Length; FCaretX:=FInputX+FInputPos; MakeInputVisible; Invalidate; end; end; VK_HOME: begin key:=0; if (not (ssAlt in Shift)) and FInput and (FInputPos<>FInputMinPos) then begin if not (ssShift in Shift) then SetSelection(-1,0) else LeftSelection(FInputMinPos,FInputPos); FInputPos:=FInputMinPos; FCaretX:=FInputX+FInputPos; MakeInputVisible; Invalidate; end; end; VK_LEFT: begin if (not (ssAlt in Shift)) and (FInput and (FInputPos>FInputMinPos)) then begin if not (ssShift in Shift) then SetSelection(-1,0) else LeftSelection(FInputPos-1,FInputPos); Dec(FInputPos); FCaretX:=FInputX+FInputPos; MakeInputVisible; Invalidate; end; end; VK_UP: begin if (not (ssAlt in Shift)) and FInput then begin SetSelection(-1,0); SetHistoryPos(FHistoryPos+1); end; end; VK_DOWN: begin if (not (ssAlt in Shift)) and FInput then begin SetSelection(-1,0); SetHistoryPos(FHistoryPos-1); end; end; VK_RIGHT: begin if (not (ssAlt in Shift)) and FInput and (FInputPos-1 then DeleteSelected else FInputBuffer.Delete(FInputPos); FHistoryPos:=0; if assigned(FOnInputChange) then FOnInputChange(Self,FInputBuffer); MakeInputVisible; AdjustLineHeight(FInputY); AdjustScrollBars; end; end; VK_RETURN: begin if FInput then begin s := FInputBuffer.GetString; s := Copy(s,FUTF8InputMinPos+1,Length(s)); if (FHistoryPos=0) then begin if (FInputBuffer.Length=FInputMinPos) or FInputIsPassWord then begin DeleteHistoryEntry(0); end else begin i:=HistoryIndexOf(s); if i>=0 then begin DeleteHistoryEntry(0); MakeFirstHistoryEntry(i); end else begin FHistory[0].Clear; FHistory[0].PartOverWrite(FInputBuffer,FInputMinPos,FInputBuffer.Length,0); end; end; end else begin DeleteHistoryEntry(0); MakeFirstHistoryEntry(FHistoryPos); end; FInput := False; if FLines[FOutY].Length<>0 then begin if FOutY>=FLineCount-1 then begin ScrollUp; Dec(FOutY); FInputY:=FOutY; AdjustLineHeight(FOutY); UpdateLineHeights; TranslateScrollBarPosition; end; FLines[FOutY+1].Clear; FLines[FOutY+1].OverWrite(FLines[FOutY],0); FLines[FOutY].Clear; if FInputIsPassWord then FLines[FOutY].OverWritePW(FInputBuffer,FInputMinPos,FInputX,FPassWordChar) else FLines[FOutY].OverWrite(FInputBuffer,FInputX); end else begin if FInputIsPassWord then FLines[FOutY].OverWritePW(FInputBuffer,FInputMinPos,FInputX,FPassWordChar) else FLines[FOutY].OverWrite(FInputBuffer,FInputX); end; Inc(FOutY); if FOutY>=FLineCount then begin ScrollUp; Dec(FOutY); FInputY:=FOutY; AdjustLineHeight(FOutY); UpdateLineHeights; TranslateScrollBarPosition; end; FOutX := 0; FCaretX := 0; FInputBuffer.Clear; if Assigned(OnInput) then OnInput(Self,s); if Assigned(OnAny) then OnAny(Self,FInputBuffer); AdjustScrollBars; Invalidate; end; end; VK_BACK: begin if FInput then begin if FSelStart<>-1 then DeleteSelected else begin If (FInputPos>FInputMinPos) then begin Dec(FInputPos); FInputBuffer.Delete(FInputPos); FCaretX:=FInputX+FInputPos; end; end; FHistoryPos:=0; if assigned(FOnInputChange) then FOnInputChange(Self,FInputBuffer); if Assigned(OnAny) then OnAny(Self,FInputBuffer); AdjustScrollBars; MakeInputVisible; If FInputVisible then Invalidate; end; end; VK_C: begin if (FInput) and (ssCtrl in Shift) then CopyToClipBoard; end; VK_V: begin if (FInput) and (ssCtrl in Shift) then PasteFromClipBoard; end; VK_X: begin if (FInput) and (ssCtrl in Shift) then CutToClipBoard; end; VK_A: begin if (FInput) and (ssCtrl in Shift) then begin SetSelection(FInputMinPos,FInputBuffer.Length); FInputPos:=FInputBuffer.Length; MakeInputVisible; if FInputVisible then Invalidate; end; end; end; if Assigned(OnAny) then OnAny(Self,FInputBuffer); end; procedure TCmdBox.InsertHistory; var i : Integer; t : TColorstring; begin t:=FHistory[FHistoryMax-1]; for i:=FHistoryMax-2 downto 0 do begin FHistory[i+1]:=FHistory[i]; end; FHistory[0] := t; FHistoryPos := 0; If FHistoryLengthLength(Desc) then Break; case Desc[Pp+1] of #9,#10,#32,#46,#196: begin if Pp+2>Length(Desc) then Break; //Incomplete Escape Seq...ignore l:=3; end; #33,#47,#197: begin if Pp+3>Length(Desc) then Break; //Incomplete Escape Seq...ignore l:=4; end; else begin l:=2; end; end; end else l:=UTF8CharacterLength(@Desc[PP]); FInputBuffer.OverWriteChar(Copy(Desc,Pp,l),i,FGraphicCharWidth,DFC,DBC); Inc(i); Inc(Pp,l); end; FInputPos := i; FInputMinPos := i; // FInputBuffer.OverWrite(Desc,0,DFC,DBC); FInputIsPassWord := False; FInputColor := IFC; FInputBackground := IBC; FInputBuffer.PassWordStart:=MaxInt; InsertHistory; MakeInputVisible; end; procedure TCmdBox.StartReadPassWord(DFC,DBC:TColor;const Desc:string;IFC,IBC:TColor); begin StartRead(DFC,DBC,Desc,IFC,IBC); FInputBuffer.PassWordStart := UTF8Length(Desc); FInputBuffer.PassWordChar := FPassWordChar; FInputIsPassWord := True; end; procedure TCmdBox.StopRead; begin FInput:=False; end; procedure TCmdBox.DeleteHistoryEntry(i:Integer); var j:Integer; Temp:TColorstring; begin Temp:=FHistory[i]; for j:=i to FHistoryLength-2 do FHistory[j]:=FHistory[j+1]; FHistory[FHistoryLength-1]:=Temp; Dec(FHistoryLength); if FHistoryPos>=i then Dec(FHistoryPos); end; procedure TCmdBox.MakeFirstHistoryEntry(i:Integer); var Temp:TColorstring; begin if FHistoryPos<>0 then begin Temp:=FHistory[i]; for i:=i-1 downto 0 do FHistory[i+1]:=FHistory[i]; FHistory[0]:=Temp; end; end; procedure TCmdBox.Clear; var i:Integer; begin for i:=0 to Length(FLines)-1 do Flines[i].Clear; FCaretX := 0; FInputY := 0; FOutX := 0; FOutY := 0; if FInput then FInputY:=0; Invalidate; end; procedure TCmdBox.Writeln(s:string); begin write(s+#13#10); end; const AnsiColors:array['0'..'7'] of TColor=(clBlack,clRed,clGreen,clYellow,clBlue,clFuchsia,clAqua,clWhite); procedure TCmdBox.IntWrite; var Pp : Integer; l : Integer; s : String; EscPos : Integer; EscSubMode : Integer; begin S := FCurrentString; Pp := 1; while Pp<=Length(S) do begin l:=1; case FEscapeMode of escmNone: begin if S[Pp]=#27 then begin case FEscapeCodeType of esctCmdBox: begin FEscapeMode := escmOperation; FEscapeData := ''; end; esctAnsi: begin FEscapeMode := escmAnsiOperation; FEscapeData := ''; end; esctNone: begin // Simply ignore it end; end; end else begin l:=UTF8CharacterLength(@S[Pp]); if l=1 then begin case s[Pp] of #13:FOutX:=0; #10: begin AdjustLineHeight(FOutY); if FLines[FOutY].Length=0 then FLines[FOutY].DefaultBackGround:=FCurrentBackGround; Inc(FOutY); if FOutY>=Length(FLines) then begin ScrollUp; Dec(FOutY); AdjustLineHeight(FOutY); UpdateLineHeights; TranslateScrollBarPosition; end; end; else begin FLines[FOutY].OverWrite(s[Pp],FOutX,FCurrentColor,FCurrentBackGround); Inc(FOutX); end; end; end else begin FLines[FOutY].OverWrite(Copy(s,Pp,l),FOutX,FCurrentColor,FCurrentBackGround); Inc(FOutX); end; end; end; escmOperation: begin case S[Pp] of #9,#10,#32,#46,#196: begin FEscapeData := S[Pp]; FEscapeMode := escmData1; end; #33,#47,#197: begin FEscapeData := S[Pp]; FEscapeMode := escmData2; end; else begin FLines[FOutY].OverWriteChar(#27+S[Pp],FOutX,FGraphicCharWidth,FCurrentColor,FCurrentBackGround); Inc(FOutX); FEscapeMode:=escmNone; end; end; end; escmData1: begin FLines[FOutY].OverWriteChar(#27+FEscapeData+S[Pp],FOutX,FGraphicCharWidth,FCurrentColor,FCurrentBackGround); Inc(FOutX); FEscapeMode:=escmNone; end; escmData2: begin FEscapeData := FEscapeData+S[Pp]; FEscapeMode := escmData1; end; escmAnsiOperation: begin case S[Pp] of '[':FEscapeMode:=escmAnsiSquare; else FEscapeMode:=escmNone; end; end; escmAnsiSquare: begin case S[Pp] of 'm': begin EscPos := 1; EscSubMode := 0; while EscPos<=Length(FEscapeData) do begin case EscSubMode of 0: begin case FEscapeData[EscPos] of '0': begin // No Reset Values know here...just assume FCurrentColor:=clSilver; FCurrentBackGround:=clBlack; end; '7': begin // Reverse? What now... end; '3':EscSubMode:=3; '4':EscSubMode:=4; end; end; 1: begin // Just collect the expected ";", not sure what to do if it isn't there... EscSubMode:=0; end; 3: begin if FEscapeData[EscPos] in ['0'..'7'] then FCurrentColor:=AnsiColors[FEscapeData[EscPos]]; EscSubMode:=1; end; 4: begin if FEscapeData[EscPos] in ['0'..'7'] then FCurrentBackGround:=AnsiColors[FEscapeData[EscPos]]; EscSubMode:=1; end; end; Inc(EscPos); end; FEscapeMode:=escmNone; end; else begin FEscapeData:=FEscapeData+S[Pp]; end; end; end; end; Inc(Pp,l); end; if FInput then begin if FLines[FOutY].Length=0 then begin if (FInputY<>FOutY) then FInputY:=FOutY; end else begin if FInputY<>FOutY+1 then FInputY:=FOutY+1; end; if FInputY>=FLineCount then begin ScrollUp; Dec(FOutY); Dec(FInputY); FInputY:=FOutY; AdjustLineHeight(FOutY); UpdateLineHeights; TranslateScrollBarPosition; end; MakeInputVisible; end else MakeOutVisible; AdjustLineHeight(FOutY); if not FInput then FCaretX:=FOutX; AdjustScrollBars; end; procedure TCmdBox.SetOutY(v:Integer); begin if v>FLineCount-1 then v:=FLineCount-1; FOutY:=v; end; procedure TCmdBox.Resize; begin inherited Resize; AdjustScrollBars; if FVSBPos>=FVisibleLineCount-FPageHeight then begin FVSBPos:=FVisibleLineCount-FPageHeight; if FVSBPos<0 then FVSBPos:=0; end; TranslateScrollBarPosition; end; function TCmdBox.AdjustLineHeight(i:Integer):Integer; var LineC : Integer; LineC2 : Integer; begin if (FInputY=i) then begin LineC := FLines[i].LineCount(FClientWidth,-1,FCaretWidth); LineC2 := FInputBuffer.LineCount(FClientWidth,FCaretX,FCaretWidth); if LineC2>LineC then LineC:=LineC2; end else LineC:=FLines[i].LineCount(FClientWidth,-1,FCaretWidth); Result := LineC; FLineHeights[i] := Result; end; function TCmdBox.UpdateLineHeights:integer; var i:integer; begin Result:=0; for i:=0 to FLineCount-1 do begin FLineHeightSum[i]:=Result; Inc(Result,AdjustLineHeight(i)); end; end; procedure TCmdBox.AdjustScrollBars; var LH : Integer; begin FClientWidth := Width-FVSBWidth; FClientHeight := Height; FPageHeight := FClientHeight div FCharHeight; FVisibleLines := FPageHeight+ord(FClientHeight mod FCharHeight<>0); LH := UpdateLineHeights; if LH<>FVisibleLineCount then begin FVisibleLineCount:=LH; if FVisibleLineCount<=FVSBPos+FPageHeight then begin FVSBPos:=FVisibleLineCount-FPageHeight; if FVSBPos<0 then FVSBPos:=0; if HandleAllocated then ScrollBarPosition(SB_Vert,FVSBPos); TranslateScrollBarPosition; end; end; if FVisibleLineCountFTopLine then begin FTopLine:=Nr; AdjustScrollBars; end; end; procedure TCmdBox.SetLineCount(c: Integer); var i:Integer; begin if c<1 then c:=1; if c<>FLineCount then begin for i:=0 to FLineCount-1 do FLines[i].Free; FLineCount:=c; SetLength(FLines,FLinecount); for i:=0 to FlineCount-1 do begin FLines[i]:=TColorstring.Create(Canvas.Font); FLines[i].DefaultBackGround:=FBackGroundColor; FLines[i].TabWidth:=FTabWidth; end; SetLength(FLineHeights,FLineCount); SetLength(FLineHeightSum,FLineCount); AdjustScrollBars; end; end; procedure TCmdBox.Paint; Var y,m : Integer; CurrentLine : Integer; begin inherited Paint; with canvas do begin if (csdesigning in componentstate) then begin Brush.Style := bsSolid; Brush.Color := clBlack; FillRect(0,0,FClientWidth,FClientHeight); exit; end; Font := FFont; Brush.Style := bsSolid; m := FVisibleLines-1; y := -FLineOfTopLine; CurrentLine := FTopLine; while (y<=m) and (CurrentLine