मैंने एक लॉग घटक लिखा है जो आपको सबसे ज्यादा चाहिए और यह विट्रुएल ट्री व्यू पर आधारित है। मुझे कुछ निर्भरताओं को हटाने के लिए कोड को थोड़ा सा बदलना पड़ा है, लेकिन यह ठीक संकलित करता है (हालांकि इसे बदलने के बाद परीक्षण नहीं किया गया है)। भले ही यह बिल्कुल सही न हो, आपको यह शुरू करने के लिए एक अच्छा आधार मिल सकता है।
यहाँ कोड
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, llInfo, llWarning, 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)), GetCellText(Node, 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, CancelEntry, 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>', Value,
'</font-color>');
llWarning: Value := concat('<font-color=clBlue>', Value,
'</font-color>');
llDebug: Value := concat('<font-color=clGreen>', Value,
'</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, 1, 2)),
StrToInt('$'+Copy(HexValue, 3, 2)),
StrToInt('$'+Copy(HexValue, 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, 1, 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, y, 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.
आप किसी भी अतिरिक्त सुविधाओं को जोड़ने, शायद आप उन्हें यहाँ पोस्ट कर सकता है।
शानदार, बढ़िया दिखने वाला घटक। अगर मैं indelicate हो सकता है, कोड में एक कॉपीराइट नोटिस है। मैं विभिन्न परियोजनाओं, कुछ वाणिज्यिक में इस से प्राप्त किसी भी घटक का उपयोग कर रहा हूं, और शायद अन्य प्रोग्रामर के साथ स्रोत साझा करना होगा। क्या ये ठीक है? क्या कोड के लिए कोई लाइसेंस है, या आप इसे सार्वजनिक डोमेन मानते हैं? –
मैं इसे सार्वजनिक डोमेन मानता हूं। जैसा कि आप करेंगे) इसके साथ करें :) यदि आप कोई अतिरिक्त जोड़ते हैं, तो मैं आपको बताने की सराहना करता हूं ताकि मैं उन्हें घटक में जोड़ सकूं। – norgepaul
निश्चित रूप से। अब तक, एकमात्र चीज जो मैं जोड़ना चाहता हूं वह है "ऑटोव्रैप" या "वर्डवाप" आसानी से लंबे लॉग संदेशों को लपेटने के लिए। कृपया इस प्रश्न पर नजर रखें या आपसे संपर्क करने का कोई तरीका प्रदान करें ताकि मैं आपको जो भी जोड़ूं उसे भेज सकूं। अपने काम और कोड को साझा करने के लिए –