用于在Delphi中显示日志信息的组件

前端之家收集整理的这篇文章主要介绍了用于在Delphi中显示日志信息的组件前端之家小编觉得挺不错的,现在分享给大家,也给大家做个参考。
我有许多复杂的处理任务,会产生消息,警告和致命错误.我希望能够在与任务无关的组件中显示这些消息.我的要求是:

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

本质上,我正在寻找某种类似列表框的组件,它支持颜色,过滤和换行.任何人都可以建议使用这样的组件(或其他组件)作为我的日志显示的基础吗?

如果做不到的话,我会写自己的.我最初的想法是,我应该使用内置的TClientDataset将组件基于TDBGrid.我会将消息添加到客户端数据集(带有消息类型的列),并通过数据集方法处理过滤,并通过网格的绘制方法进行着色.

欢迎您对此设计的看法.

[注意:此时我对将日志写入文件或与Windows日志记录集成并不特别感兴趣(除非这样做解决了我的显示问题)]

解决方法

我编写了一个日志组件,可以完成您所需的大部分工作,它基于VitrualTreeView.我必须稍微改变代码删除一些依赖项,但它编译得很好(尽管它在更改后没有经过测试).即使它不是您所需要的,它也可能为您提供良好的入门基础.

这是代码

  1. unit UserInterface.VirtualTrees.LogTree;
  2.  
  3. // Copyright (c) Paul Thornton
  4.  
  5. interface
  6.  
  7. uses
  8. Classes,SysUtils,Graphics,Types,Windows,ImgList,Menus,VirtualTrees;
  9.  
  10. type
  11. TLogLevel = (llNone,llError,llInfo,llWarning,llDebug);
  12.  
  13. TLogLevels = set of TLogLevel;
  14.  
  15. TLogNodeData = record
  16. LogLevel: TLogLevel;
  17. Timestamp: TDateTime;
  18. LogText: String;
  19. end;
  20. PLogNodeData = ^TLogNodeData;
  21.  
  22. TOnLog = procedure(Sender: TObject; var LogText: String; var
  23. CancelEntry: Boolean; LogLevel: TLogLevel) of object;
  24. TOnPopupMenuItemClick = procedure(Sender: TObject; MenuItem:
  25. TMenuItem) of object;
  26.  
  27. TVirtualLogPopupmenu = class(TPopupMenu)
  28. private
  29. FOwner: TComponent;
  30. FOnPopupMenuItemClick: TOnPopupMenuItemClick;
  31.  
  32. procedure OnMenuItemClick(Sender: TObject);
  33. public
  34. constructor Create(AOwner: TComponent); override;
  35.  
  36. property OnPopupMenuItemClick: TOnPopupMenuItemClick read
  37. FOnPopupMenuItemClick write FOnPopupMenuItemClick;
  38. end;
  39.  
  40. TVirtualLogTree = class(TVirtualStringTree)
  41. private
  42. FOnLog: TOnLog;
  43. FOnAfterLog: TNotifyEvent;
  44.  
  45. FHTMLSupport: Boolean;
  46. FAutoScroll: Boolean;
  47. FRemoveControlCharacters: Boolean;
  48. FLogLevels: TLogLevels;
  49. FAutoLogLevelColours: Boolean;
  50. FShowDateColumn: Boolean;
  51. FShowImages: Boolean;
  52. FMaximumLines: Integer;
  53.  
  54. function DrawHTML(const ARect: TRect; const ACanvas: TCanvas;
  55. const Text: String; Selected: Boolean): Integer;
  56. function GetCellText(const Node: PVirtualNode; const Column:
  57. TColumnIndex): String;
  58. procedure SetLogLevels(const Value: TLogLevels);
  59. procedure UpdateVisibleItems;
  60. procedure OnPopupMenuItemClick(Sender: TObject; MenuItem: TMenuItem);
  61. procedure SetShowDateColumn(const Value: Boolean);
  62. procedure SetShowImages(const Value: Boolean);
  63. procedure AddDefaultColumns(const ColumnNames: array of String;
  64. const ColumnWidths: array of Integer);
  65. function IfThen(Condition: Boolean; TrueResult,FalseResult: Variant): Variant;
  66. function StripHTMLTags(const Value: string): string;
  67. function RemoveCtrlChars(const Value: String): String;
  68. protected
  69. procedure DoOnLog(var LogText: String; var CancelEntry: Boolean;
  70. LogLevel: TLogLevel); virtual;
  71. procedure DoOnAfterLog; virtual;
  72.  
  73. procedure DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode;
  74. Column: TColumnIndex; CellRect: TRect); override;
  75. procedure DoGetText(Node: PVirtualNode; Column: TColumnIndex;
  76. TextType: TVSTTextType; var Text: String); override;
  77. procedure DoFreeNode(Node: PVirtualNode); override;
  78. function DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind;
  79. Column: TColumnIndex; var Ghosted: Boolean; var Index: Integer):
  80. TCustomImageList; override;
  81. procedure DoPaintText(Node: PVirtualNode; const Canvas: TCanvas;
  82. Column: TColumnIndex; TextType: TVSTTextType); override;
  83. procedure Loaded; override;
  84. public
  85. constructor Create(AOwner: TComponent); override;
  86.  
  87. procedure Log(Value: String; LogLevel: TLogLevel = llInfo;
  88. TimeStamp: TDateTime = 0);
  89. procedure LogFmt(Value: String; const Args: array of Const;
  90. LogLevel: TLogLevel = llInfo; TimeStamp: TDateTime = 0);
  91. procedure SaveToFileWithDialog;
  92. procedure SaveToFile(const Filename: String);
  93. procedure SaveToStrings(const Strings: TStrings);
  94. procedure CopyToClipboard; reintroduce;
  95. published
  96. property OnLog: TOnLog read FOnLog write FOnLog;
  97. property OnAfterLog: TNotifyEvent read FOnAfterLog write FOnAfterLog;
  98.  
  99. property HTMLSupport: Boolean read FHTMLSupport write FHTMLSupport;
  100. property AutoScroll: Boolean read FAutoScroll write FAutoScroll;
  101. property RemoveControlCharacters: Boolean read
  102. FRemoveControlCharacters write FRemoveControlCharacters;
  103. property LogLevels: TLogLevels read FLogLevels write SetLogLevels;
  104. property AutoLogLevelColours: Boolean read FAutoLogLevelColours
  105. write FAutoLogLevelColours;
  106. property ShowDateColumn: Boolean read FShowDateColumn write
  107. SetShowDateColumn;
  108. property ShowImages: Boolean read FShowImages write SetShowImages;
  109. property MaximumLines: Integer read FMaximumLines write FMaximumLines;
  110. end;
  111.  
  112. implementation
  113.  
  114. uses
  115. Dialogs,Clipbrd;
  116.  
  117. resourcestring
  118. StrSaveLog = '&Save';
  119. StrCopyToClipboard = '&Copy';
  120. StrTextFilesTxt = 'Text files (*.txt)|*.txt|All files (*.*)|*.*';
  121. StrSave = 'Save';
  122. StrDate = 'Date';
  123. StrLog = 'Log';
  124.  
  125. constructor TVirtualLogTree.Create(AOwner: TComponent);
  126. begin
  127. inherited;
  128.  
  129. FAutoScroll := TRUE;
  130. FHTMLSupport := TRUE;
  131. FRemoveControlCharacters := TRUE;
  132. FShowDateColumn := TRUE;
  133. FShowImages := TRUE;
  134. FLogLevels := [llError,llDebug];
  135.  
  136. NodeDataSize := SizeOf(TLogNodeData);
  137. end;
  138.  
  139. procedure TVirtualLogTree.DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode;
  140. Column: TColumnIndex; CellRect: TRect);
  141. var
  142. ColWidth: Integer;
  143. begin
  144. inherited;
  145.  
  146. if Column = 1 then
  147. begin
  148. if FHTMLSupport then
  149. ColWidth := DrawHTML(CellRect,Canvas,GetCellText(Node,Column),Selected[Node])
  150. else
  151. ColWidth := Canvas.TextWidth(GetCellText(Node,Column));
  152.  
  153. if not FShowDateColumn then
  154. ColWidth := ColWidth + 32; // Width of image
  155.  
  156. if ColWidth > Header.Columns[1].MinWidth then
  157. Header.Columns[1].MinWidth := ColWidth;
  158. end;
  159. end;
  160.  
  161. procedure TVirtualLogTree.DoFreeNode(Node: PVirtualNode);
  162. var
  163. NodeData: PLogNodeData;
  164. begin
  165. inherited;
  166.  
  167. NodeData := GetNodeData(Node);
  168.  
  169. if Assigned(NodeData) then
  170. NodeData.LogText := '';
  171. end;
  172.  
  173. function TVirtualLogTree.DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind;
  174. Column: TColumnIndex; var Ghosted: Boolean;
  175. var Index: Integer): TCustomImageList;
  176. var
  177. NodeData: PLogNodeData;
  178. begin
  179. Images.Count;
  180.  
  181. if ((FShowImages) and (Kind in [ikNormal,ikSelected])) and
  182. (((FShowDateColumn) and (Column <= 0)) or
  183. ((not FShowDateColumn) and (Column = 1))) then
  184. begin
  185. NodeData := GetNodeData(Node);
  186.  
  187. if Assigned(NodeData) then
  188. case NodeData.LogLevel of
  189. llError: Index := 3;
  190. llInfo: Index := 2;
  191. llWarning: Index := 1;
  192. llDebug: Index := 0;
  193. else
  194. Index := 4;
  195. end;
  196. end;
  197.  
  198. Result := inherited DoGetImageIndex(Node,Kind,Column,Ghosted,Index);
  199. end;
  200.  
  201. procedure TVirtualLogTree.DoGetText(Node: PVirtualNode; Column: TColumnIndex;
  202. TextType: TVSTTextType; var Text: String);
  203. begin
  204. inherited;
  205.  
  206. if (TextType = ttNormal) and ((Column <= 0) or (not FHTMLSupport)) then
  207. Text := GetCellText(Node,Column)
  208. else
  209. Text := '';
  210. end;
  211.  
  212. procedure TVirtualLogTree.DoOnAfterLog;
  213. begin
  214. if Assigned(FOnAfterLog) then
  215. FOnAfterLog(Self);
  216. end;
  217.  
  218. procedure TVirtualLogTree.DoOnLog(var LogText: String; var
  219. CancelEntry: Boolean; LogLevel: TLogLevel);
  220. begin
  221. if Assigned(FOnLog) then
  222. FOnLog(Self,LogText,CancelEntry,LogLevel);
  223. end;
  224.  
  225. procedure TVirtualLogTree.DoPaintText(Node: PVirtualNode; const Canvas: TCanvas;
  226. Column: TColumnIndex; TextType: TVSTTextType);
  227. begin
  228. inherited;
  229.  
  230. Canvas.Font.Color := clBlack;
  231. end;
  232.  
  233. function TVirtualLogTree.GetCellText(const Node: PVirtualNode; const
  234. Column: TColumnIndex): String;
  235. var
  236. NodeData: PLogNodeData;
  237. begin
  238. NodeData := GetNodeData(Node);
  239.  
  240. if Assigned(NodeData) then
  241. case Column of
  242. -1,0: Result := concat(DateTimeToStr(NodeData.Timestamp),'.',FormatDateTime('zzz',NodeData.Timestamp));
  243. 1: Result := NodeData.LogText;
  244. end;
  245. end;
  246.  
  247. procedure TVirtualLogTree.AddDefaultColumns(
  248. const ColumnNames: array of String; const ColumnWidths: array of Integer);
  249. var
  250. i: Integer;
  251. Column: TVirtualTreeColumn;
  252. begin
  253. Header.Columns.Clear;
  254.  
  255. if High(ColumnNames) <> high(ColumnWidths) then
  256. raise Exception.Create('Number of column names must match the
  257. number of column widths.') // Do not localise
  258. else
  259. begin
  260. for i := low(ColumnNames) to high(ColumnNames) do
  261. begin
  262. Column := Header.Columns.Add;
  263.  
  264. Column.Text := ColumnNames[i];
  265.  
  266. if ColumnWidths[i] > 0 then
  267. Column.Width := ColumnWidths[i]
  268. else
  269. begin
  270. Header.AutoSizeIndex := Column.Index;
  271. Header.Options := Header.Options + [hoAutoResize];
  272. end;
  273. end;
  274. end;
  275. end;
  276.  
  277. procedure TVirtualLogTree.Loaded;
  278. begin
  279. inherited;
  280.  
  281. TreeOptions.PaintOptions := TreeOptions.PaintOptions - [toShowRoot,toShowTreeLines,toShowButtons] + [toUseBlendedSelection,toShowHorzGridLines,toHideFocusRect];
  282. TreeOptions.SelectionOptions := TreeOptions.SelectionOptions +
  283. [toFullRowSelect,toRightClickSelect];
  284.  
  285. AddDefaultColumns([StrDate,StrLog],[170,120]);
  286.  
  287. Header.AutoSizeIndex := 1;
  288. Header.Columns[1].MinWidth := 300;
  289. Header.Options := Header.Options + [hoAutoResize];
  290.  
  291. if (PopupMenu = nil) and (not (csDesigning in ComponentState)) then
  292. begin
  293. PopupMenu := TVirtualLogPopupmenu.Create(Self);
  294. TVirtualLogPopupmenu(PopupMenu).OnPopupMenuItemClick :=
  295. OnPopupMenuItemClick;
  296. end;
  297.  
  298. SetShowDateColumn(FShowDateColumn);
  299. end;
  300.  
  301. procedure TVirtualLogTree.OnPopupMenuItemClick(Sender: TObject;
  302. MenuItem: TMenuItem);
  303. begin
  304. if MenuItem.Tag = 1 then
  305. SaveToFileWithDialog
  306. else
  307. if MenuItem.Tag = 2 then
  308. CopyToClipboard;
  309. end;
  310.  
  311. procedure TVirtualLogTree.SaveToFileWithDialog;
  312. var
  313. SaveDialog: TSaveDialog;
  314. begin
  315. SaveDialog := TSaveDialog.Create(Self);
  316. try
  317. SaveDialog.DefaultExt := '.txt';
  318. SaveDialog.Title := StrSave;
  319. SaveDialog.Options := SaveDialog.Options + [ofOverwritePrompt];
  320. SaveDialog.Filter := StrTextFilesTxt;
  321.  
  322. if SaveDialog.Execute then
  323. SaveToFile(SaveDialog.Filename);
  324. finally
  325. FreeAndNil(SaveDialog);
  326. end;
  327. end;
  328.  
  329. procedure TVirtualLogTree.SaveToFile(const Filename: String);
  330. var
  331. SaveStrings: TStringList;
  332. begin
  333. SaveStrings := TStringList.Create;
  334. try
  335. SaveToStrings(SaveStrings);
  336.  
  337. SaveStrings.SaveToFile(Filename);
  338. finally
  339. FreeAndNil(SaveStrings);
  340. end;
  341. end;
  342.  
  343. procedure TVirtualLogTree.CopyToClipboard;
  344. var
  345. CopyStrings: TStringList;
  346. begin
  347. CopyStrings := TStringList.Create;
  348. try
  349. SaveToStrings(CopyStrings);
  350.  
  351. Clipboard.AsText := CopyStrings.Text;
  352. finally
  353. FreeAndNil(CopyStrings);
  354. end;
  355. end;
  356.  
  357. function TVirtualLogTree.IfThen(Condition: Boolean; TrueResult,FalseResult: Variant): Variant;
  358. begin
  359. if Condition then
  360. Result := TrueResult
  361. else
  362. Result := FalseResult;
  363. end;
  364.  
  365. function TVirtualLogTree.StripHTMLTags(const Value: string): string;
  366. var
  367. TagBegin,TagEnd,TagLength: integer;
  368. begin
  369. Result := Value;
  370.  
  371. TagBegin := Pos( '<',Result); // search position of first <
  372.  
  373. while (TagBegin > 0) do
  374. begin
  375. TagEnd := Pos('>',Result);
  376. TagLength := TagEnd - TagBegin + 1;
  377.  
  378. Delete(Result,TagBegin,TagLength);
  379. TagBegin:= Pos( '<',Result);
  380. end;
  381. end;
  382.  
  383. procedure TVirtualLogTree.SaveToStrings(const Strings: TStrings);
  384. var
  385. Node: PVirtualNode;
  386. begin
  387. Node := GetFirst;
  388.  
  389. while Assigned(Node) do
  390. begin
  391. Strings.Add(concat(IfThen(FShowDateColumn,concat(GetCellText(Node,0),#09),''),IfThen(FHTMLSupport,StripHTMLTags(GetCellText(Node,1)),1))));
  392.  
  393. Node := Node.NextSibling;
  394. end;
  395. end;
  396.  
  397. function TVirtualLogTree.RemoveCtrlChars(const Value: String): String;
  398. var
  399. i: Integer;
  400. begin
  401. // Replace CTRL characters with <whitespace>
  402. Result := '';
  403.  
  404. for i := 1 to length(Value) do
  405. if (AnsiChar(Value[i]) in [#0..#31,#127]) then
  406. Result := Result + ' '
  407. else
  408. Result := Result + Value[i];
  409. end;
  410.  
  411. procedure TVirtualLogTree.Log(Value: String; LogLevel: TLogLevel;
  412. TimeStamp: TDateTime);
  413. var
  414. CancelEntry: Boolean;
  415. Node: PVirtualNode;
  416. NodeData: PLogNodeData;
  417. DoScroll: Boolean;
  418. begin
  419. CancelEntry := FALSE;
  420.  
  421. DoOnLog(Value,LogLevel);
  422.  
  423. if not CancelEntry then
  424. begin
  425. DoScroll := ((not Focused) or (GetLast = FocusedNode)) and (FAutoScroll);
  426.  
  427. Node := AddChild(nil);
  428.  
  429. NodeData := GetNodeData(Node);
  430.  
  431. if Assigned(NodeData) then
  432. begin
  433. NodeData.LogLevel := LogLevel;
  434.  
  435. if TimeStamp = 0 then
  436. NodeData.Timestamp := now
  437. else
  438. NodeData.Timestamp := TimeStamp;
  439.  
  440. if FRemoveControlCharacters then
  441. Value := RemoveCtrlChars(Value);
  442.  
  443.  
  444. if FAutoLogLevelColours then
  445. case LogLevel of
  446. llError: Value := concat('<font-color=clRed>',Value,'</font-color>');
  447. llInfo: Value := concat('<font-color=clBlack>','</font-color>');
  448. llWarning: Value := concat('<font-color=clBlue>','</font-color>');
  449. llDebug: Value := concat('<font-color=clGreen>','</font-color>')
  450. end;
  451.  
  452. NodeData.LogText := Value;
  453.  
  454. IsVisible[Node] := NodeData.LogLevel in FLogLevels;
  455.  
  456. DoOnAfterLog;
  457. end;
  458.  
  459. if FMaximumLines <> 0 then
  460. while RootNodeCount > FMaximumLines do
  461. DeleteNode(GetFirst);
  462.  
  463. if DoScroll then
  464. begin
  465. //SelectNodeEx(GetLast);
  466.  
  467. ScrollIntoView(GetLast,FALSE);
  468. end;
  469. end;
  470. end;
  471.  
  472. procedure TVirtualLogTree.LogFmt(Value: String; const Args: Array of
  473. Const; LogLevel: TLogLevel; TimeStamp: TDateTime);
  474. begin
  475. Log(format(Value,Args),LogLevel,TimeStamp);
  476. end;
  477.  
  478. procedure TVirtualLogTree.SetLogLevels(const Value: TLogLevels);
  479. begin
  480. FLogLevels := Value;
  481.  
  482. UpdateVisibleItems;
  483. end;
  484.  
  485. procedure TVirtualLogTree.SetShowDateColumn(const Value: Boolean);
  486. begin
  487. FShowDateColumn := Value;
  488.  
  489. if Header.Columns.Count > 0 then
  490. begin
  491. if FShowDateColumn then
  492. Header.Columns[0].Options := Header.Columns[0].Options + [coVisible]
  493. else
  494. Header.Columns[0].Options := Header.Columns[0].Options - [coVisible]
  495. end;
  496. end;
  497.  
  498. procedure TVirtualLogTree.SetShowImages(const Value: Boolean);
  499. begin
  500. FShowImages := Value;
  501.  
  502. Invalidate;
  503. end;
  504.  
  505. procedure TVirtualLogTree.UpdateVisibleItems;
  506. var
  507. Node: PVirtualNode;
  508. NodeData: PLogNodeData;
  509. begin
  510. BeginUpdate;
  511. try
  512. Node := GetFirst;
  513.  
  514. while Assigned(Node) do
  515. begin
  516. NodeData := GetNodeData(Node);
  517.  
  518. if Assigned(NodeData) then
  519. IsVisible[Node] := NodeData.LogLevel in FLogLevels;
  520.  
  521. Node := Node.NextSibling;
  522. end;
  523.  
  524. Invalidate;
  525. finally
  526. EndUpdate;
  527. end;
  528. end;
  529.  
  530. function TVirtualLogTree.DrawHTML(const ARect: TRect; const ACanvas:
  531. TCanvas; const Text: String; Selected: Boolean): Integer;
  532. (*DrawHTML - Draws text on a canvas using tags based on a simple
  533. subset of HTML/CSS
  534.  
  535. <B> - Bold e.g. <B>This is bold</B>
  536. <I> - Italic e.g. <I>This is italic</I>
  537. <U> - Underline e.g. <U>This is underlined</U>
  538. <font-color=x> Font colour e.g.
  539. <font-color=clRed>Delphi red</font-color>
  540. <font-color=#FFFFFF>Web white</font-color>
  541. <font-color=$000000>Hex black</font-color>
  542. <font-size=x> Font size e.g. <font-size=30>This is some big text</font-size>
  543. <font-family> Font family e.g. <font-family=Arial>This is
  544. arial</font-family>*)
  545.  
  546. function CloseTag(const ATag: String): String;
  547. begin
  548. Result := concat('/',ATag);
  549. end;
  550.  
  551. function GetTagValue(const ATag: String): String;
  552. var
  553. p: Integer;
  554. begin
  555. p := pos('=',ATag);
  556.  
  557. if p = 0 then
  558. Result := ''
  559. else
  560. Result := copy(ATag,p + 1,MaxInt);
  561. end;
  562.  
  563. function ColorCodeToColor(const Value: String): TColor;
  564. var
  565. HexValue: String;
  566. begin
  567. Result := 0;
  568.  
  569. if Value <> '' then
  570. begin
  571. if (length(Value) >= 2) and (copy(Uppercase(Value),1,2) = 'CL') then
  572. begin
  573. // Delphi colour
  574. Result := StringToColor(Value);
  575. end else
  576. if Value[1] = '#' then
  577. begin
  578. // Web colour
  579. HexValue := copy(Value,2,6);
  580.  
  581. Result := RGB(StrToInt('$'+Copy(HexValue,2)),StrToInt('$'+Copy(HexValue,3,5,2)));
  582. end
  583. else
  584. // Hex or decimal colour
  585. Result := StrToIntDef(Value,0);
  586. end;
  587. end;
  588.  
  589. const
  590. TagBold = 'B';
  591. TagItalic = 'I';
  592. TagUnderline = 'U';
  593. TagBreak = 'BR';
  594. TagFontSize = 'FONT-SIZE';
  595. TagFontFamily = 'FONT-FAMILY';
  596. TagFontColour = 'FONT-COLOR';
  597. TagColour = 'COLOUR';
  598.  
  599. var
  600. x,y,idx,CharWidth,MaxCharHeight: Integer;
  601. CurrChar: Char;
  602. Tag,TagValue: String;
  603. PrevIoUsFontColour: TColor;
  604. PrevIoUsFontFamily: String;
  605. PrevIoUsFontSize: Integer;
  606. PrevIoUsColour: TColor;
  607.  
  608. begin
  609. ACanvas.Font.Size := Canvas.Font.Size;
  610. ACanvas.Font.Name := Canvas.Font.Name;
  611.  
  612. //if Selected and Focused then
  613. // ACanvas.Font.Color := clWhite
  614. //else
  615. ACanvas.Font.Color := Canvas.Font.Color;
  616. ACanvas.Font.Style := Canvas.Font.Style;
  617.  
  618. PrevIoUsFontColour := ACanvas.Font.Color;
  619. PrevIoUsFontFamily := ACanvas.Font.Name;
  620. PrevIoUsFontSize := ACanvas.Font.Size;
  621. PrevIoUsColour := ACanvas.Brush.Color;
  622.  
  623. x := ARect.Left;
  624. y := ARect.Top + 1;
  625. idx := 1;
  626.  
  627. MaxCharHeight := ACanvas.TextHeight('Ag');
  628.  
  629. While idx <= length(Text) do
  630. begin
  631. CurrChar := Text[idx];
  632.  
  633. // Is this a tag?
  634. if CurrChar = '<' then
  635. begin
  636. Tag := '';
  637.  
  638. inc(idx);
  639.  
  640. // Find the end of then tag
  641. while (Text[idx] <> '>') and (idx <= length(Text)) do
  642. begin
  643. Tag := concat(Tag,UpperCase(Text[idx]));
  644.  
  645. inc(idx);
  646. end;
  647.  
  648. ///////////////////////////////////////////////////
  649. // Simple tags
  650. ///////////////////////////////////////////////////
  651. if Tag = TagBold then
  652. ACanvas.Font.Style := ACanvas.Font.Style + [fsBold] else
  653.  
  654. if Tag = TagItalic then
  655. ACanvas.Font.Style := ACanvas.Font.Style + [fsItalic] else
  656.  
  657. if Tag = TagUnderline then
  658. ACanvas.Font.Style := ACanvas.Font.Style + [fsUnderline] else
  659.  
  660. if Tag = TagBreak then
  661. begin
  662. x := ARect.Left;
  663.  
  664. inc(y,MaxCharHeight);
  665. end else
  666.  
  667. ///////////////////////////////////////////////////
  668. // Closing tags
  669. ///////////////////////////////////////////////////
  670. if Tag = CloseTag(TagBold) then
  671. ACanvas.Font.Style := ACanvas.Font.Style - [fsBold] else
  672.  
  673. if Tag = CloseTag(TagItalic) then
  674. ACanvas.Font.Style := ACanvas.Font.Style - [fsItalic] else
  675.  
  676. if Tag = CloseTag(TagUnderline) then
  677. ACanvas.Font.Style := ACanvas.Font.Style - [fsUnderline] else
  678.  
  679. if Tag = CloseTag(TagFontSize) then
  680. ACanvas.Font.Size := PrevIoUsFontSize else
  681.  
  682. if Tag = CloseTag(TagFontFamily) then
  683. ACanvas.Font.Name := PrevIoUsFontFamily else
  684.  
  685. if Tag = CloseTag(TagFontColour) then
  686. ACanvas.Font.Color := PrevIoUsFontColour else
  687.  
  688. if Tag = CloseTag(TagColour) then
  689. ACanvas.Brush.Color := PrevIoUsColour else
  690.  
  691. ///////////////////////////////////////////////////
  692. // Tags with values
  693. ///////////////////////////////////////////////////
  694. begin
  695. // Get the tag value (everything after '=')
  696. TagValue := GetTagValue(Tag);
  697.  
  698. if TagValue <> '' then
  699. begin
  700. // Remove the value from the tag
  701. Tag := copy(Tag,pos('=',Tag) - 1);
  702.  
  703. if Tag = TagFontSize then
  704. begin
  705. PrevIoUsFontSize := ACanvas.Font.Size;
  706. ACanvas.Font.Size := StrToIntDef(TagValue,ACanvas.Font.Size);
  707. end else
  708.  
  709. if Tag = TagFontFamily then
  710. begin
  711. PrevIoUsFontFamily := ACanvas.Font.Name;
  712. ACanvas.Font.Name := TagValue;
  713. end;
  714.  
  715. if Tag = TagFontColour then
  716. begin
  717. PrevIoUsFontColour := ACanvas.Font.Color;
  718.  
  719. try
  720. ACanvas.Font.Color := ColorCodeToColor(TagValue);
  721. except
  722. //Just in case the canvas colour is invalid
  723. end;
  724. end else
  725.  
  726. if Tag = TagColour then
  727. begin
  728. PrevIoUsColour := ACanvas.Brush.Color;
  729.  
  730. try
  731. ACanvas.Brush.Color := ColorCodeToColor(TagValue);
  732. except
  733. //Just in case the canvas colour is invalid
  734. end;
  735. end;
  736. end;
  737. end;
  738. end
  739. else
  740. // Draw the character if it's not a ctrl char
  741. if CurrChar >= #32 then
  742. begin
  743. CharWidth := ACanvas.TextWidth(CurrChar);
  744.  
  745. if y + MaxCharHeight < ARect.Bottom then
  746. begin
  747. ACanvas.Brush.Style := bsClear;
  748.  
  749. ACanvas.TextOut(x,CurrChar);
  750. end;
  751.  
  752. x := x + CharWidth;
  753. end;
  754.  
  755. inc(idx);
  756. end;
  757.  
  758. Result := x - ARect.Left;
  759. end;
  760.  
  761. { TVirtualLogPopupmenu }
  762.  
  763. constructor TVirtualLogPopupmenu.Create(AOwner: TComponent);
  764.  
  765. function AddMenuItem(const ACaption: String; ATag: Integer): TMenuItem;
  766. begin
  767. Result := TMenuItem.Create(Self);
  768.  
  769. Result.Caption := ACaption;
  770. Result.Tag := ATag;
  771. Result.OnClick := OnMenuItemClick;
  772.  
  773. Items.Add(Result);
  774. end;
  775.  
  776. begin
  777. inherited Create(AOwner);
  778.  
  779. FOwner := AOwner;
  780.  
  781. AddMenuItem(StrSaveLog,1);
  782. AddMenuItem('-',-1);
  783. AddMenuItem(StrCopyToClipboard,2);
  784. end;
  785.  
  786. procedure TVirtualLogPopupmenu.OnMenuItemClick(Sender: TObject);
  787. begin
  788. if Assigned(FOnPopupMenuItemClick) then
  789. FOnPopupMenuItemClick(Self,TMenuItem(Sender));
  790. end;
  791.  
  792. end.

如果您添加任何其他功能,也许您可​​以在此处发布.

猜你在找的Delphi相关文章