我有许多复杂的处理任务,它们会产生消息,警告和致命错误。我希望能够在与任务无关的组件中显示这些消息。我的要求是:

  • 不同类型的消息以不同的字体和/或背景颜色显示。
  • 可以对显示进行过滤以包括或排除每种消息。
  • 显示屏将通过包装长消息并显示整个消息来正确处理长消息。
  • 每个消息都可以附加某种数据引用,并且可以将消息选择为实体(例如,写入RTF备忘录将不起作用)。

  • 本质上,我正在寻找某种列表框,例如支持颜色,过滤和换行的组件。谁能建议这样的组件(或另一个)用作我的日志显示的基础?

    如果没有,我会写我自己的。我最初的想法是,我应该将组件基于具有内置TClientDataset的TDBGrid。我将消息添加到客户端数据集(消息类型为一列),并通过数据集方法进行过滤,并通过网格的draw方法进行着色。

    欢迎您提出关于此设计的想法。

    [注意:目前,我对将日志写入文件或与Windows日志记录集成并没有特别的兴趣(除非这样做可以解决我的显示问题)]

    最佳答案

    我编写了一个日志组件,它基于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.
    

    如果添加任何其他功能,也许可以在此处发布它们。

    关于delphi - 在Delphi中显示日志信息的组件,我们在Stack Overflow上找到一个类似的问题:https://stackoverflow.com/questions/2343496/

    10-11 21:59
    查看更多