Компонент для отображения информации о журнале в Delphi

Я написал компонент журнала, который делает большую часть того, что вам нужно, и он основан на 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, 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.

Если вы добавите какие-либо дополнительные возможности, возможно, вы могли бы опубликовать их здесь.