interface
uses Forms,Controls,StdCtrls,ExtCtrls,RichMemo; //note: add pl_RichMemo in Project Inspector - Required Packages when compiling
var {console public variables}
ConsoleWindowEnabled:boolean;
ConsoleCurrentColor:tcolor;
procedure GetTextSizeEx(AText: string; AFont: string; AFontSize:word; var Shape:TShape; var sizex,sizey:longint);
procedure CreateConsoleWindow();
procedure ShowConsoleWindow();
procedure ConsoleResize(Rows,Cols:word);
procedure ConsoleChangeFont(name:string;size:longint;Rows,Cols:word);
procedure ConsoleClear();
procedure ConsoleRestore();
procedure ConsoleMinimize();
procedure ConsoleWrite(s:string);
procedure ConsoleOut(s:string);
implementation
type TConsoleButtonMinimizeRestore=class(TButton)
procedure Click(Sender:TObject);
end;
var {console private variables}
ConsoleWindow:TForm;
ConsoleBttnMinimizeRestore:TConsoleButtonMinimizeRestore;
ConsoleWindowShape:TShape;
ConsoleWindowMemo:TRichMemo;
ConsoleFontName:string;
ConsoleFontSize:word;
ConsoleTextLimit:longint;
ConsoleColorBuffer:array of TColor;
ConsoleTextBuffer:string;
ConsoleWindowMinimized:boolean;
ConsoleWindowRows,ConsoleWindowColumns:word;
procedure ConsoleRefresh(); forward;
procedure ConsoleChangeState(); forward;
procedure TConsoleButtonMinimizeRestore.Click(Sender:TObject);
begin
ConsoleChangeState();
end;
procedure GetTextSizeEx(AText: string; AFont: string; AFontSize:word; var Shape:TShape; var sizex,sizey:longint);
var ofn:string;
ofs:longint;
begin
ofn:=shape.canvas.Font.Name;
ofs:=shape.canvas.font.Size;
shape.canvas.Font.Name:=Afont;
shape.canvas.Font.Size:=AFontSize;
sizex := shape.canvas.TextWidth(AText);
sizey := shape.canvas.TextHeight(AText);
shape.canvas.Font.Name:=ofn;
shape.canvas.Font.Size:=ofs;
end;
//must call from inside another form in order to be created
procedure CreateConsoleWindow;
var szx,szy,diff:longint;
begin
if ConsoleWindowEnabled=true then
if ConsoleWindow=nil then begin
ConsoleWindow:=TForm.Create(nil);
ConsoleWindow.Parent:=nil;
//size up window with a tolerance of 10 pixels up and down
ConsoleWindow.SetBounds(100,100,200,120);
diff:=ConsoleWindow.Height-ConsoleWindow.ClientHeight;
ConsoleWindow.BorderStyle := bsToolWindow;
ConsoleWindow.Caption:='Console Window';
ConsoleWindowShape:=TShape.Create(nil);
ConsoleWindowShape.Parent:=ConsoleWindow;
ConsoleWindowShape.Top:=0;
ConsoleWindowShape.Left:=0;
ConsoleWindowShape.Width:=1;
ConsoleWindowShape.Height:=1;
ConsoleWindowMemo:=TRichMemo.Create(nil);
ConsoleWindowMemo.Parent:=ConsoleWindow;
ConsoleWindowMemo.Top:=31;
ConsoleWindowMemo.left:=1;
ConsoleWindowMemo.Width:=ConsoleWindow.Width-1;
ConsoleWindowMemo.Height:=ConsoleWindow.Height-1;
ConsoleWindowMemo.Color:=clBlack;
ConsoleWindowMemo.WordWrap:=false;
ConsoleWindowMemo.Enabled:=false;
ConsoleWindowMemo.Font.Name:=ConsoleFontName;
ConsoleWindowMemo.Font.Size:=ConsoleFontSize;
ConsoleWindowMemo.Font.Color:=ConsoleCurrentColor;
GetTextSizeEx('X',ConsoleFontName,ConsoleFontSize,ConsoleWindowShape,szx,szy);
ConsoleWindow.SetBounds(ConsoleWindow.Top,ConsoleWindow.Left,szx*ConsoleWindowColumns+10,szy*ConsoleWindowRows+10+diff+(2*szy+4));
ConsoleBttnMinimizeRestore:=TConsoleButtonMinimizeRestore.Create(nil);
ConsoleBttnMinimizeRestore.Parent:=ConsoleWindow;
ConsoleBttnMinimizeRestore.Top:=1;
ConsoleBttnMinimizeRestore.Left:=1;
ConsoleBttnMinimizeRestore.Width:=ConsoleWindow.Width-2;
ConsoleBttnMinimizeRestore.Height:=2*szy+2;
ConsoleBttnMinimizeRestore.Caption:=' Minimize ';
ConsoleBttnMinimizeRestore.OnClick:=@ConsoleBttnMinimizeRestore.Click; //seems a tautology, as it doesn't allow the use of TConsoleMinimizeRestoreClass as it should
ConsoleWindowMemo.Top:=2*szy+3;
ConsoleWindowMemo.left:=1;
ConsoleWindowMemo.Width:=ConsoleWindow.Width-2;
ConsoleWindowMemo.Height:=ConsoleWindow.Height-2;
end;
end;
procedure ConsoleResize(Rows,Cols:word);
var szx,szy,diff:longint;
begin
CreateConsoleWindow();
if ConsoleWindowMinimized=true then ConsoleRestore();
if ConsoleWindowEnabled=true then begin
diff:=ConsoleWindow.Height-ConsoleWindow.ClientHeight;
GetTextSizeEx('X',ConsoleFontName,ConsoleFontSize,ConsoleWindowShape,szx,szy);
//size up window with a tolerance of 10 pixels up and down
ConsoleWindow.SetBounds(ConsoleWindow.Top,ConsoleWindow.Left,szx*Cols+10,szy*Rows+10+diff+(2*szy+4));
ConsoleBttnMinimizeRestore.Width:=ConsoleWindow.Width-2;
ConsoleWindowMemo.Width:=ConsoleWindow.Width-2;
ConsoleWindowMemo.Height:=ConsoleWindow.Height;
ConsoleWindowRows:=Rows;
ConsoleWindowColumns:=Cols;
ConsoleRefresh();
end;
end;
procedure ConsoleChangeFont(name:string;size:longint;Rows,Cols:word);
begin
CreateConsoleWindow();
ConsoleFontName:=name;
ConsoleFontSize:=size;
ConsoleResize(Rows,Cols);
end;
procedure ConsoleMinimize();
var szx,szy:longint;
begin
CreateConsoleWindow();
if ConsoleWindowMinimized=true then exit;
if ConsoleWindowEnabled=true then begin
GetTextSizeEx('X',ConsoleFontName,ConsoleFontSize,ConsoleWindowShape,szx,szy);
ConsoleWindowMinimized:=true;
ConsoleWindowMemo.Hide();
ConsoleWindow.Height:=(2*szy+2);
ConsoleBttnMinimizeRestore.Caption:='Restore';
ConsoleWindow.Refresh();
end;
end;
procedure ConsoleRestore();
var szx,szy,diff:longint;
begin
CreateConsoleWindow();
if ConsoleWindowMinimized=false then exit;
if ConsoleWindowEnabled=true then begin
ConsoleWindowMinimized:=false;
diff:=ConsoleWindow.Height-ConsoleWindow.ClientHeight;
GetTextSizeEx('X',ConsoleFontName,ConsoleFontSize,ConsoleWindowShape,szx,szy);
//size up window with a tolerance of 10 pixels up and down
ConsoleWindow.SetBounds(ConsoleWindow.Top,ConsoleWindow.Left,szx*ConsoleWindowColumns+10,szy*ConsoleWindowRows+10+diff+31);
ConsoleWindowMemo.Show();
ConsoleBttnMinimizeRestore.Caption:='Minimize';
ConsoleRefresh();
end;
end;
procedure ConsoleChangeState();
begin
if ConsoleWindowMinimized=true then ConsoleRestore()
else ConsoleMinimize();
end;
procedure ShowConsoleWindow;
begin
CreateConsoleWindow();
if ConsoleWindowEnabled=true then begin
ConsoleWindow.Show();
ConsoleRefresh();
end;
end;
procedure ConsoleClear();
begin
CreateConsoleWindow();
ConsoleTextBuffer:='';
SetLength(ConsoleColorBuffer,0);
if ConsoleWindowEnabled=true then ConsoleWindowMemo.Text:='';
end;
procedure ConsoleRefresh();
type change=record begins,lengthof:longint; colorof:tcolor;end;
var i:longint;v,lastlen:word;lc,tf,beginp,endp:longint;c:string;
fp:tfontparams;slen:longint;colortext:tcolor;
changes:array of change; changehere:change; ichange:longint;
begin
SetLength(changes,0);
if ConsoleWindowMinimized=true then exit;
CreateConsoleWindow();
if ConsoleWindowEnabled=true then begin
//fontparams defaults
with fp do begin
Name:=ConsoleFontName;
Color:=ConsoleCurrentColor;
Size:=ConsoleFontSize;
Style:=[];
HasBkClr:=false;
BkColor:=clBlack;
VScriptPos:=vpNormal;
end;
//locate display position
lc:=length(ConsoleTextBuffer);
i:=lc;v:=1;lastlen:=0;tf:=1;
if i<>0
then repeat
c:=copy(ConsoleTextBuffer,i,1);
if c=#13
then begin v:=v+1; lastlen:=0; if v>ConsoleWindowRows then begin tf:=i+1;break; end; end
else begin
lastlen:=lastlen+1;
if lastlen>ConsoleWindowColumns then begin
lastlen:=1;
v:=v+1;
if v>ConsoleWindowRows then begin tf:=i+1;break; end;
end;
end;
i:=i-1;
until i=0;
//display block and list color changes
ConsoleWindowMemo.Text:='';
lastlen:=0;
for i:=tf to lc do begin
if i=tf then begin colortext:=ConsoleColorBuffer[i-1];beginp:=length(ConsoleWindowMemo.Text)+1;end
else if ConsoleColorBuffer[i-1]<>colortext then begin
endp:=length(ConsoleWindowMemo.Text); slen:=endp-beginp+1;
with changehere do begin begins:=beginp-1;lengthof:=slen;colorof:=colortext;end;
SetLength(changes,Length(changes)+1);
changes[length(changes)-1]:=changehere;
colortext:=ConsoleColorBuffer[i-1];beginp:=length(ConsoleWindowMemo.Text)+1;
end;
if lastlen=ConsoleWindowColumns
then begin
ConsoleWindowMemo.Text:=ConsoleWindowMemo.Text+#13;
if ConsoleTextBuffer[i]<>#13 then ConsoleWindowMemo.Text:=ConsoleWindowMemo.Text+ConsoleTextBuffer[i]; //inhibit double line feed
lastlen:=0;
end
else begin
ConsoleWindowMemo.Text:=ConsoleWindowMemo.Text+ConsoleTextBuffer[i];
if ConsoleTextBuffer[i]=#13 then lastlen:=0 else lastlen:=lastlen+1;
end;
end;//for i:=tf...
endp:=length(ConsoleWindowMemo.Text); slen:=endp-beginp+1;
with changehere do begin begins:=beginp-1;lengthof:=slen; colorof:=colortext;end;
SetLength(changes,Length(changes)+1);
changes[length(changes)-1]:=changehere;
//implement color changes
for ichange:=0 to Length(Changes)-1 do begin
fp.color:=changes[ichange].colorof;
ConsoleWindowMemo.SetTextAttributes(changes[ichange].begins,changes[ichange].colorof,fp);
end;
ConsoleWindow.Refresh();
end;//if ConsoleWindowEnabled=true
end;
procedure ConsoleWrite(s:string);
var newtext:string;lc:longint;lt,i,posi:longint;
begin
CreateConsoleWindow();
if ConsoleWindowEnabled=true then begin
//newtext:=strclear(#0+#10,strtran(s,#9,' ',1,0)); //clears nulls and LF and changes tabs
newtext:=s; //removed these references for this code ; strclear removes nulls and linefeeds, strtran changes tabs into a few spaces
ConsoleTextBuffer:=ConsoleTextBuffer+newtext;
lt:=length(newtext);
SetLength(ConsoleColorBuffer,Length(ConsoleColorBuffer)+lt);
lc:=length(ConsoleColorBuffer);
for i:=1 to length(newtext) do ConsoleColorBuffer[lc-lt+i-1]:=ConsoleCurrentColor; //e.g. for (30) do CC[5020-30+30-1] (aka 5019)
if length(ConsoleTextBuffer)>ConsoleTextLimit then begin
posi:=length(ConsoleTextBuffer)-ConsoleTextlimit+1; //eg 5020-5000+1 : 21
ConsoleTextBuffer:=copy(ConsoleTextBuffer,posi,ConsoleTextLimit); //eg from 21, for 5000 -> 5020
for i:=0 to ConsoleTextLimit-1 do ConsoleColorBuffer[i]:=ConsoleColorBuffer[posi-1+i]; //eg. from 1 to 5000, assign for [0..4999] from [21+1-2]
end;
if ConsoleWindowMinimized=false then ConsoleRefresh();
end;
end;
procedure ConsoleOut(s:string);
begin
ConsoleWrite(s+#13);
end;
begin
ConsoleFontName:='Courier New';
ConsoleFontSize:=10;
ConsoleTextLimit:=5000;
ConsoleTextBuffer:='';
ConsoleCurrentColor:=clLtGray;
ConsoleWindowEnabled:=true;
ConsoleWindowMinimized:=false;
ConsoleWindow:=nil;
ConsoleWindowRows:=10;
ConsoleWindowColumns:=35;
end.
Recent
