我有许多复杂的处理任务,会产生消息,警告和致命错误.我希望能够在与任务无关的组件中显示这些消息.我的要求是：
>不同种类的消息以不同的字体和/或背景颜色显示.
>可以过滤显示以包括或排除每种消息.
>显示器将通过包装它们并显示整个消息来正确处理长消息.
>每条消息都可以附加某种类型的数据引用,并且可以选择消息作为实体(例如,写入RTF备忘录将不起作用).
本质上,我正在寻找某种类似列表框的组件,它支持颜色,过滤和换行.任何人都可以建议使用这样的组件(或其他组件)作为我的日志显示的基础吗？
如果做不到的话,我会写自己的.我最初的想法是,我应该使用内置的TClientDataset将组件基于TDBGrid.我会将消息添加到客户端数据集(带有消息类型的列),并通过数据集方法处理过滤,并通过网格的绘制方法进行着色.
欢迎您对此设计的看法.
解决方法
我编写了一个日志组件,可以完成您所需的大部分工作,它基于VitrualTreeView.我必须稍微改变代码以删除一些依赖项,但它编译得很好(尽管它在更改后没有经过测试).即使它不是您所需要的,它也可能为您提供良好的入门基础.
这是代码
unit UserInterface.VirtualTrees.LogTree;
// Copyright (c) Paul Thornton
interface
uses
Classes,SysUtils,Graphics,Types,Windows,ImgList,Menus,VirtualTrees;
type
TLogLevel = (llNone,llError,llInfo,llWarning,llDebug);
TLogLevels = set of TLogLevel;
TLogNodeData = record
LogLevel: TLogLevel;
Timestamp: TDateTime;
LogText: String;
end;
PLogNodeData = ^TLogNodeData;
TOnLog = procedure(Sender: TObject; var LogText: String; var
CancelEntry: Boolean; LogLevel: TLogLevel) of object;
TOnPopupMenuItemClick = procedure(Sender: TObject; MenuItem:
TMenuItem) of object;
TVirtualLogPopupmenu = class(TPopupMenu)
private
FOwner: TComponent;
FOnPopupMenuItemClick: TOnPopupMenuItemClick;
procedure OnMenuItemClick(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
property OnPopupMenuItemClick: TOnPopupMenuItemClick read
FOnPopupMenuItemClick write FOnPopupMenuItemClick;
end;
TVirtualLogTree = class(TVirtualStringTree)
private
FOnLog: TOnLog;
FOnAfterLog: TNotifyEvent;
FHTMLSupport: Boolean;
FAutoScroll: Boolean;
FRemoveControlCharacters: Boolean;
FLogLevels: TLogLevels;
FAutoLogLevelColours: Boolean;
FShowDateColumn: Boolean;
FShowImages: Boolean;
FMaximumLines: Integer;
function DrawHTML(const ARect: TRect; const ACanvas: TCanvas;
const Text: String; Selected: Boolean): Integer;
function GetCellText(const Node: PVirtualNode; const Column:
TColumnIndex): String;
procedure SetLogLevels(const Value: TLogLevels);
procedure UpdateVisibleItems;
procedure OnPopupMenuItemClick(Sender: TObject; MenuItem: TMenuItem);
procedure SetShowDateColumn(const Value: Boolean);
procedure SetShowImages(const Value: Boolean);
procedure AddDefaultColumns(const ColumnNames: array of String;
const ColumnWidths: array of Integer);
function IfThen(Condition: Boolean; TrueResult,FalseResult: Variant): Variant;
function StripHTMLTags(const Value: string): string;
function RemoveCtrlChars(const Value: String): String;
protected
procedure DoOnLog(var LogText: String; var CancelEntry: Boolean;
LogLevel: TLogLevel); virtual;
procedure DoOnAfterLog; virtual;
procedure DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode;
Column: TColumnIndex; CellRect: TRect); override;
procedure DoGetText(Node: PVirtualNode; Column: TColumnIndex;
TextType: TVSTTextType; var Text: String); override;
procedure DoFreeNode(Node: PVirtualNode); override;
function DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind;
Column: TColumnIndex; var Ghosted: Boolean; var Index: Integer):
TCustomImageList; override;
procedure DoPaintText(Node: PVirtualNode; const Canvas: TCanvas;
Column: TColumnIndex; TextType: TVSTTextType); override;
procedure Loaded; override;
public
constructor Create(AOwner: TComponent); override;
procedure Log(Value: String; LogLevel: TLogLevel = llInfo;
TimeStamp: TDateTime = 0);
procedure LogFmt(Value: String; const Args: array of Const;
LogLevel: TLogLevel = llInfo; TimeStamp: TDateTime = 0);
procedure SaveToFileWithDialog;
procedure SaveToFile(const Filename: String);
procedure SaveToStrings(const Strings: TStrings);
procedure CopyToClipboard; reintroduce;
published
property OnLog: TOnLog read FOnLog write FOnLog;
property OnAfterLog: TNotifyEvent read FOnAfterLog write FOnAfterLog;
property HTMLSupport: Boolean read FHTMLSupport write FHTMLSupport;
property AutoScroll: Boolean read FAutoScroll write FAutoScroll;
property RemoveControlCharacters: Boolean read
FRemoveControlCharacters write FRemoveControlCharacters;
property LogLevels: TLogLevels read FLogLevels write SetLogLevels;
property AutoLogLevelColours: Boolean read FAutoLogLevelColours
write FAutoLogLevelColours;
property ShowDateColumn: Boolean read FShowDateColumn write
SetShowDateColumn;
property ShowImages: Boolean read FShowImages write SetShowImages;
property MaximumLines: Integer read FMaximumLines write FMaximumLines;
end;
implementation
uses
Dialogs,Clipbrd;
resourcestring
StrSaveLog = '&Save';
StrCopyToClipboard = '&Copy';
StrTextFilesTxt = 'Text files (*.txt)|*.txt|All files (*.*)|*.*';
StrSave = 'Save';
StrDate = 'Date';
StrLog = 'Log';
constructor TVirtualLogTree.Create(AOwner: TComponent);
begin
inherited;
FAutoScroll := TRUE;
FHTMLSupport := TRUE;
FRemoveControlCharacters := TRUE;
FShowDateColumn := TRUE;
FShowImages := TRUE;
FLogLevels := [llError,llDebug];
NodeDataSize := SizeOf(TLogNodeData);
end;
procedure TVirtualLogTree.DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode;
Column: TColumnIndex; CellRect: TRect);
var
ColWidth: Integer;
begin
inherited;
if Column = 1 then
begin
if FHTMLSupport then
ColWidth := DrawHTML(CellRect,Canvas,GetCellText(Node,Column),Selected[Node])
else
ColWidth := Canvas.TextWidth(GetCellText(Node,Column));
if not FShowDateColumn then
ColWidth := ColWidth + 32; // Width of image
if ColWidth > Header.Columns[1].MinWidth then
Header.Columns[1].MinWidth := ColWidth;
end;
end;
procedure TVirtualLogTree.DoFreeNode(Node: PVirtualNode);
var
NodeData: PLogNodeData;
begin
inherited;
NodeData := GetNodeData(Node);
if Assigned(NodeData) then
NodeData.LogText := '';
end;
function TVirtualLogTree.DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind;
Column: TColumnIndex; var Ghosted: Boolean;
var Index: Integer): TCustomImageList;
var
NodeData: PLogNodeData;
begin
Images.Count;
if ((FShowImages) and (Kind in [ikNormal,ikSelected])) and
(((FShowDateColumn) and (Column <= 0)) or
((not FShowDateColumn) and (Column = 1))) then
begin
NodeData := GetNodeData(Node);
if Assigned(NodeData) then
case NodeData.LogLevel of
llError: Index := 3;
llInfo: Index := 2;
llWarning: Index := 1;
llDebug: Index := 0;
else
Index := 4;
end;
end;
Result := inherited DoGetImageIndex(Node,Kind,Column,Ghosted,Index);
end;
procedure TVirtualLogTree.DoGetText(Node: PVirtualNode; Column: TColumnIndex;
TextType: TVSTTextType; var Text: String);
begin
inherited;
if (TextType = ttNormal) and ((Column <= 0) or (not FHTMLSupport)) then
Text := GetCellText(Node,Column)
else
Text := '';
end;
procedure TVirtualLogTree.DoOnAfterLog;
begin
if Assigned(FOnAfterLog) then
FOnAfterLog(Self);
end;
procedure TVirtualLogTree.DoOnLog(var LogText: String; var
CancelEntry: Boolean; LogLevel: TLogLevel);
begin
if Assigned(FOnLog) then
FOnLog(Self,LogText,CancelEntry,LogLevel);
end;
procedure TVirtualLogTree.DoPaintText(Node: PVirtualNode; const Canvas: TCanvas;
Column: TColumnIndex; TextType: TVSTTextType);
begin
inherited;
Canvas.Font.Color := clBlack;
end;
function TVirtualLogTree.GetCellText(const Node: PVirtualNode; const
Column: TColumnIndex): String;
var
NodeData: PLogNodeData;
begin
NodeData := GetNodeData(Node);
if Assigned(NodeData) then
case Column of
-1,0: Result := concat(DateTimeToStr(NodeData.Timestamp),'.',FormatDateTime('zzz',NodeData.Timestamp));
1: Result := NodeData.LogText;
end;
end;
procedure TVirtualLogTree.AddDefaultColumns(
const ColumnNames: array of String; const ColumnWidths: array of Integer);
var
i: Integer;
Column: TVirtualTreeColumn;
begin
Header.Columns.Clear;
if High(ColumnNames) <> high(ColumnWidths) then
raise Exception.Create('Number of column names must match the
number of column widths.') // Do not localise
else
begin
for i := low(ColumnNames) to high(ColumnNames) do
begin
Column := Header.Columns.Add;
Column.Text := ColumnNames[i];
if ColumnWidths[i] > 0 then
Column.Width := ColumnWidths[i]
else
begin
Header.AutoSizeIndex := Column.Index;
Header.Options := Header.Options + [hoAutoResize];
end;
end;
end;
end;
procedure TVirtualLogTree.Loaded;
begin
inherited;
TreeOptions.PaintOptions := TreeOptions.PaintOptions - [toShowRoot,toShowTreeLines,toShowButtons] + [toUseBlendedSelection,toShowHorzGridLines,toHideFocusRect];
TreeOptions.SelectionOptions := TreeOptions.SelectionOptions +
[toFullRowSelect,toRightClickSelect];
AddDefaultColumns([StrDate,StrLog],[170,120]);
Header.AutoSizeIndex := 1;
Header.Columns[1].MinWidth := 300;
Header.Options := Header.Options + [hoAutoResize];
if (PopupMenu = nil) and (not (csDesigning in ComponentState)) then
begin
PopupMenu := TVirtualLogPopupmenu.Create(Self);
TVirtualLogPopupmenu(PopupMenu).OnPopupMenuItemClick :=
OnPopupMenuItemClick;
end;
SetShowDateColumn(FShowDateColumn);
end;
procedure TVirtualLogTree.OnPopupMenuItemClick(Sender: TObject;
MenuItem: TMenuItem);
begin
if MenuItem.Tag = 1 then
SaveToFileWithDialog
else
if MenuItem.Tag = 2 then
CopyToClipboard;
end;
procedure TVirtualLogTree.SaveToFileWithDialog;
var
SaveDialog: TSaveDialog;
begin
SaveDialog := TSaveDialog.Create(Self);
try
SaveDialog.DefaultExt := '.txt';
SaveDialog.Title := StrSave;
SaveDialog.Options := SaveDialog.Options + [ofOverwritePrompt];
SaveDialog.Filter := StrTextFilesTxt;
if SaveDialog.Execute then
SaveToFile(SaveDialog.Filename);
finally
FreeAndNil(SaveDialog);
end;
end;
procedure TVirtualLogTree.SaveToFile(const Filename: String);
var
SaveStrings: TStringList;
begin
SaveStrings := TStringList.Create;
try
SaveToStrings(SaveStrings);
SaveStrings.SaveToFile(Filename);
finally
FreeAndNil(SaveStrings);
end;
end;
procedure TVirtualLogTree.CopyToClipboard;
var
CopyStrings: TStringList;
begin
CopyStrings := TStringList.Create;
try
SaveToStrings(CopyStrings);
Clipboard.AsText := CopyStrings.Text;
finally
FreeAndNil(CopyStrings);
end;
end;
function TVirtualLogTree.IfThen(Condition: Boolean; TrueResult,FalseResult: Variant): Variant;
begin
if Condition then
Result := TrueResult
else
Result := FalseResult;
end;
function TVirtualLogTree.StripHTMLTags(const Value: string): string;
var
TagBegin,TagEnd,TagLength: integer;
begin
Result := Value;
TagBegin := Pos( '<',Result); // search position of first <
while (TagBegin > 0) do
begin
TagEnd := Pos('>',Result);
TagLength := TagEnd - TagBegin + 1;
Delete(Result,TagBegin,TagLength);
TagBegin:= Pos( '<',Result);
end;
end;
procedure TVirtualLogTree.SaveToStrings(const Strings: TStrings);
var
Node: PVirtualNode;
begin
Node := GetFirst;
while Assigned(Node) do
begin
Strings.Add(concat(IfThen(FShowDateColumn,concat(GetCellText(Node,0),#09),''),IfThen(FHTMLSupport,StripHTMLTags(GetCellText(Node,1)),1))));
Node := Node.NextSibling;
end;
end;
function TVirtualLogTree.RemoveCtrlChars(const Value: String): String;
var
i: Integer;
begin
// Replace CTRL characters with <whitespace>
Result := '';
for i := 1 to length(Value) do
if (AnsiChar(Value[i]) in [#0..#31,#127]) then
Result := Result + ' '
else
Result := Result + Value[i];
end;
procedure TVirtualLogTree.Log(Value: String; LogLevel: TLogLevel;
TimeStamp: TDateTime);
var
CancelEntry: Boolean;
Node: PVirtualNode;
NodeData: PLogNodeData;
DoScroll: Boolean;
begin
CancelEntry := FALSE;
DoOnLog(Value,LogLevel);
if not CancelEntry then
begin
DoScroll := ((not Focused) or (GetLast = FocusedNode)) and (FAutoScroll);
Node := AddChild(nil);
NodeData := GetNodeData(Node);
if Assigned(NodeData) then
begin
NodeData.LogLevel := LogLevel;
if TimeStamp = 0 then
NodeData.Timestamp := now
else
NodeData.Timestamp := TimeStamp;
if FRemoveControlCharacters then
Value := RemoveCtrlChars(Value);
if FAutoLogLevelColours then
case LogLevel of
llError: Value := concat('<font-color=clRed>',Value,'</font-color>');
llInfo: Value := concat('<font-color=clBlack>','</font-color>');
llWarning: Value := concat('<font-color=clBlue>','</font-color>');
llDebug: Value := concat('<font-color=clGreen>','</font-color>')
end;
NodeData.LogText := Value;
IsVisible[Node] := NodeData.LogLevel in FLogLevels;
DoOnAfterLog;
end;
if FMaximumLines <> 0 then
while RootNodeCount > FMaximumLines do
DeleteNode(GetFirst);
if DoScroll then
begin
//SelectNodeEx(GetLast);
ScrollIntoView(GetLast,FALSE);
end;
end;
end;
procedure TVirtualLogTree.LogFmt(Value: String; const Args: Array of
Const; LogLevel: TLogLevel; TimeStamp: TDateTime);
begin
Log(format(Value,Args),LogLevel,TimeStamp);
end;
procedure TVirtualLogTree.SetLogLevels(const Value: TLogLevels);
begin
FLogLevels := Value;
UpdateVisibleItems;
end;
procedure TVirtualLogTree.SetShowDateColumn(const Value: Boolean);
begin
FShowDateColumn := Value;
if Header.Columns.Count > 0 then
begin
if FShowDateColumn then
Header.Columns[0].Options := Header.Columns[0].Options + [coVisible]
else
Header.Columns[0].Options := Header.Columns[0].Options - [coVisible]
end;
end;
procedure TVirtualLogTree.SetShowImages(const Value: Boolean);
begin
FShowImages := Value;
Invalidate;
end;
procedure TVirtualLogTree.UpdateVisibleItems;
var
Node: PVirtualNode;
NodeData: PLogNodeData;
begin
BeginUpdate;
try
Node := GetFirst;
while Assigned(Node) do
begin
NodeData := GetNodeData(Node);
if Assigned(NodeData) then
IsVisible[Node] := NodeData.LogLevel in FLogLevels;
Node := Node.NextSibling;
end;
Invalidate;
finally
EndUpdate;
end;
end;
function TVirtualLogTree.DrawHTML(const ARect: TRect; const ACanvas:
TCanvas; const Text: String; Selected: Boolean): Integer;
(*DrawHTML - Draws text on a canvas using tags based on a simple
subset of HTML/CSS
<B> - Bold e.g. <B>This is bold</B>
<I> - Italic e.g. <I>This is italic</I>
<U> - Underline e.g. <U>This is underlined</U>
<font-color=x> Font colour e.g.
<font-color=clRed>Delphi red</font-color>
<font-color=#FFFFFF>Web white</font-color>
<font-color=$000000>Hex black</font-color>
<font-size=x> Font size e.g. <font-size=30>This is some big text</font-size>
<font-family> Font family e.g. <font-family=Arial>This is
arial</font-family>*)
function CloseTag(const ATag: String): String;
begin
Result := concat('/',ATag);
end;
function GetTagValue(const ATag: String): String;
var
p: Integer;
begin
p := pos('=',ATag);
if p = 0 then
Result := ''
else
Result := copy(ATag,p + 1,MaxInt);
end;
function ColorCodeToColor(const Value: String): TColor;
var
HexValue: String;
begin
Result := 0;
if Value <> '' then
begin
if (length(Value) >= 2) and (copy(Uppercase(Value),1,2) = 'CL') then
begin
// Delphi colour
Result := StringToColor(Value);
end else
if Value[1] = '#' then
begin
// Web colour
HexValue := copy(Value,2,6);
Result := RGB(StrToInt('$'+Copy(HexValue,2)),StrToInt('$'+Copy(HexValue,3,5,2)));
end
else
// Hex or decimal colour
Result := StrToIntDef(Value,0);
end;
end;
const
TagBold = 'B';
TagItalic = 'I';
TagUnderline = 'U';
TagBreak = 'BR';
TagFontSize = 'FONT-SIZE';
TagFontFamily = 'FONT-FAMILY';
TagFontColour = 'FONT-COLOR';
TagColour = 'COLOUR';
var
x,y,idx,CharWidth,MaxCharHeight: Integer;
CurrChar: Char;
Tag,TagValue: String;
PrevIoUsFontColour: TColor;
PrevIoUsFontFamily: String;
PrevIoUsFontSize: Integer;
PrevIoUsColour: TColor;
begin
ACanvas.Font.Size := Canvas.Font.Size;
ACanvas.Font.Name := Canvas.Font.Name;
//if Selected and Focused then
// ACanvas.Font.Color := clWhite
//else
ACanvas.Font.Color := Canvas.Font.Color;
ACanvas.Font.Style := Canvas.Font.Style;
PrevIoUsFontColour := ACanvas.Font.Color;
PrevIoUsFontFamily := ACanvas.Font.Name;
PrevIoUsFontSize := ACanvas.Font.Size;
PrevIoUsColour := ACanvas.Brush.Color;
x := ARect.Left;
y := ARect.Top + 1;
idx := 1;
MaxCharHeight := ACanvas.TextHeight('Ag');
While idx <= length(Text) do
begin
CurrChar := Text[idx];
// Is this a tag?
if CurrChar = '<' then
begin
Tag := '';
inc(idx);
// Find the end of then tag
while (Text[idx] <> '>') and (idx <= length(Text)) do
begin
Tag := concat(Tag,UpperCase(Text[idx]));
inc(idx);
end;
///////////////////////////////////////////////////
// Simple tags
///////////////////////////////////////////////////
if Tag = TagBold then
ACanvas.Font.Style := ACanvas.Font.Style + [fsBold] else
if Tag = TagItalic then
ACanvas.Font.Style := ACanvas.Font.Style + [fsItalic] else
if Tag = TagUnderline then
ACanvas.Font.Style := ACanvas.Font.Style + [fsUnderline] else
if Tag = TagBreak then
begin
x := ARect.Left;
inc(y,MaxCharHeight);
end else
///////////////////////////////////////////////////
// Closing tags
///////////////////////////////////////////////////
if Tag = CloseTag(TagBold) then
ACanvas.Font.Style := ACanvas.Font.Style - [fsBold] else
if Tag = CloseTag(TagItalic) then
ACanvas.Font.Style := ACanvas.Font.Style - [fsItalic] else
if Tag = CloseTag(TagUnderline) then
ACanvas.Font.Style := ACanvas.Font.Style - [fsUnderline] else
if Tag = CloseTag(TagFontSize) then
ACanvas.Font.Size := PrevIoUsFontSize else
if Tag = CloseTag(TagFontFamily) then
ACanvas.Font.Name := PrevIoUsFontFamily else
if Tag = CloseTag(TagFontColour) then
ACanvas.Font.Color := PrevIoUsFontColour else
if Tag = CloseTag(TagColour) then
ACanvas.Brush.Color := PrevIoUsColour else
///////////////////////////////////////////////////
// Tags with values
///////////////////////////////////////////////////
begin
// Get the tag value (everything after '=')
TagValue := GetTagValue(Tag);
if TagValue <> '' then
begin
// Remove the value from the tag
Tag := copy(Tag,pos('=',Tag) - 1);
if Tag = TagFontSize then
begin
PrevIoUsFontSize := ACanvas.Font.Size;
ACanvas.Font.Size := StrToIntDef(TagValue,ACanvas.Font.Size);
end else
if Tag = TagFontFamily then
begin
PrevIoUsFontFamily := ACanvas.Font.Name;
ACanvas.Font.Name := TagValue;
end;
if Tag = TagFontColour then
begin
PrevIoUsFontColour := ACanvas.Font.Color;
try
ACanvas.Font.Color := ColorCodeToColor(TagValue);
except
//Just in case the canvas colour is invalid
end;
end else
if Tag = TagColour then
begin
PrevIoUsColour := ACanvas.Brush.Color;
try
ACanvas.Brush.Color := ColorCodeToColor(TagValue);
except
//Just in case the canvas colour is invalid
end;
end;
end;
end;
end
else
// Draw the character if it's not a ctrl char
if CurrChar >= #32 then
begin
CharWidth := ACanvas.TextWidth(CurrChar);
if y + MaxCharHeight < ARect.Bottom then
begin
ACanvas.Brush.Style := bsClear;
ACanvas.TextOut(x,CurrChar);
end;
x := x + CharWidth;
end;
inc(idx);
end;
Result := x - ARect.Left;
end;
{ TVirtualLogPopupmenu }
constructor TVirtualLogPopupmenu.Create(AOwner: TComponent);
function AddMenuItem(const ACaption: String; ATag: Integer): TMenuItem;
begin
Result := TMenuItem.Create(Self);
Result.Caption := ACaption;
Result.Tag := ATag;
Result.OnClick := OnMenuItemClick;
Items.Add(Result);
end;
begin
inherited Create(AOwner);
FOwner := AOwner;
AddMenuItem(StrSaveLog,1);
AddMenuItem('-',-1);
AddMenuItem(StrCopyToClipboard,2);
end;
procedure TVirtualLogPopupmenu.OnMenuItemClick(Sender: TObject);
begin
if Assigned(FOnPopupMenuItemClick) then
FOnPopupMenuItemClick(Self,TMenuItem(Sender));
end;
end.