home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d12345 / MISC.ZIP / Mlabel.pas < prev    next >
Pascal/Delphi Source File  |  2001-05-02  |  28KB  |  894 lines
  1. unit Mlabel;
  2.  
  3. {-----------------------------------------------------------------------------
  4. The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at
  5.  
  6. http://www.mozilla.org/MPL/MPL-1.1.html
  7.  
  8. Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License.
  9.  
  10. The Original Code is: MLabel.pas, released 12 September 2000.
  11.  
  12. The Initial Developer of the Original Code is Mat Ballard.
  13. Portions created by Mat Ballard are Copyright (C) 1999 Mat Ballard.
  14. Portions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.
  15. All Rights Reserved.
  16.  
  17. Contributor(s): Mat Ballard                 e-mail: mat.ballard@chemware.hypermart.net.
  18.  
  19. Last Modified: 05/25/2000
  20. Current Version: 2.00
  21.  
  22. You may retrieve the latest version of this file from:
  23.  
  24.         http://Chemware.hypermart.net/
  25.  
  26. This work was created with the Project JEDI VCL guidelines:
  27.  
  28.         http://www.delphi-jedi.org/Jedi:VCLVCL
  29.  
  30. in mind. 
  31.  
  32.  
  33. Purpose:
  34. This component is similar to TLabel, but adds the ability to make every line
  35. a different color.
  36.  
  37.  
  38. Known Issues:
  39. -----------------------------------------------------------------------------}
  40.  
  41. {$I Misc.inc}
  42.  
  43. interface
  44.  
  45. uses
  46.   Classes, SysUtils,
  47. {$IFDEF WINDOWS}
  48.   WinTypes, WinProcs,
  49.   Controls, Forms, Graphics, Menus, StdCtrls,
  50. {$ENDIF}
  51. {$IFDEF WIN32}
  52.   Windows,
  53.   Controls, Forms, Graphics, Menus, StdCtrls,
  54. {$ENDIF}
  55. {$IFDEF LINUX}
  56.   Types, Untranslated,
  57.   QControls, QForms, QGraphics, QMenus, QStdCtrls,
  58. {$ENDIF}
  59.   Misc;
  60.  
  61. type
  62.   {Colors = (clAqua,
  63. clBlack, clBlue, clDkGray, clFuchsia, clGray, clGreen, clLime, clLtGray,
  64. clMaroon, clNavy, clOlive, clPurple, clRed, clSilver, clTeal, clWhite, clYellow,
  65. clActiveBorder, clActiveCaption, clAppWorkSpace, clBackground, clBtnFace,
  66. clBtnHighlight, clBtnShadow, clBtnText, clCaptionText, clGrayText, clHighlight,
  67. clHighlightText, clInactiveBorder, clInactiveCaption, clInactiveCaptionText,
  68. clMenu, clMenuText, clScrollBar, clWindow, clWindowFrame, clWindowText);}
  69.  
  70.   {TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideFrame)}
  71.  
  72.   TDirection = (dRight, dLeft, dUp, dDown);
  73.   {dRight means normal left-to-right}
  74.   {dLeft means upside-down}
  75.   {dUp means the text reads upwards}
  76.   {dDown means the text reads downwards}
  77.  
  78.   et_Popup = (puBorders,
  79.               puBorderWidth,
  80.               puColor,
  81.               puDirection,
  82.               puEdit,
  83.               puFont,
  84.               puLineLength,
  85.               puSameColor,
  86.               puTransparent);
  87.  
  88. {$IFNDEF DELPHI4_UP}
  89.   TBorderWidth = 0..MaxInt;
  90. {$ENDIF}
  91. {$IFDEF KYLIX1}
  92.   TBorderWidth = 0..MaxInt;
  93. {$ENDIF}
  94.  
  95.   TMultiLabel = class(TCustomLabel)
  96.   private
  97.     { Private declarations }
  98.     FBorderStyle: TBorderStyle;
  99.     FBorderWidth: TBorderWidth;
  100.     FCaption: TStringList;
  101.     FDirection: TDirection;
  102.     FLineLength: Word;
  103. {the nice stuff:}
  104.     TextEdit: TMemo;
  105.     MyPopup: TPopupMenu;
  106.  
  107. {general variables:}
  108.  
  109.     Procedure SetCaption(Value: TStringList);
  110.     Procedure SetBorderStyle(Value: TBorderStyle);
  111.     Procedure SetBorderWidth(Value: TBorderWidth);
  112.     Procedure SetDirection(Value: TDirection);
  113.     Procedure SetLineLength(Value: Word);
  114.     {Procedure SetAutoSize(Value: Boolean);}
  115.   protected
  116.     {procedure AdjustBounds;}
  117.     {This overrides TCustomLabel's method}
  118.     procedure DoDrawText(Text: String; var Rect: TRect; Flags: LongInt);{$IFDEF DELPHI4_UP} reintroduce;{$ENDIF}
  119.     {This overrides TCustomLabel's method}
  120.     Function ExtractColor(Index: Integer): TColor; virtual;
  121.     {This extracts the color from the full caption.}
  122.     Function ExtractPenStyle(Index: Integer): TPenStyle; virtual;
  123.     {This extracts the color from the full caption.}
  124.     Function ExtractText(Index: Integer): String; virtual;
  125.     {This extracts the text from the full caption, thereby removing the color
  126.      information from display..}
  127.     Procedure Outline; virtual;
  128.     {This draws the border around the text.}
  129.     Procedure SetSize; virtual;
  130.  
  131. {mouse response procedures:}
  132.     Procedure DblClick; Override;
  133.     procedure EditFinished(Sender: TObject);
  134.     procedure EditKeyDown(Sender: TObject;
  135.                           var Key: Word;
  136.                           Shift: TShiftState);
  137.  
  138.   public
  139.     { Public declarations }
  140.     Constructor Create(AOwner: TComponent); override;
  141.     {This is the normal constructor. It initializes the caption and some properties.}
  142.     Destructor Destroy; override;
  143.     {This is the normal destructor. It frees the caption.}
  144.     Procedure Paint; override;
  145.     {This is the new Paint procedure that draws the coloured text on the canvas.}
  146.  
  147.   published
  148.     Property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle;
  149.     {This is the normal BorderStyle, which is found in TButton but not in TLabel.}
  150.     Property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth;
  151.     {This sets the width of the gap between the text and the border}
  152.     Property Caption: TStringList read FCaption write SetCaption;
  153.     {This is a list of the strings that you want to display, along with the
  154.      colour information. The required format is:}
  155.     {}
  156.     {Text that you want to display//DelphiColor}
  157.     {}
  158.     {where DelphiColor is the name of the Delphi color that you want
  159.      (eg: clAqua, clBlack, clBlue, clDkGray, etc.}
  160.  
  161.     Property Direction: TDirection read FDirection write SetDirection;
  162.  
  163.     Property LineLength: Word read FLineLength write SetLineLength;
  164.  
  165. {the inherited properties in TLabel we want:}
  166.     property Align;
  167.     property Alignment;
  168.     property AutoSize;
  169.     property Color;
  170.     property DragCursor;
  171.     property DragMode;
  172.     property Enabled;
  173.     property FocusControl;
  174.     property Font;
  175.     property ParentColor;
  176.     property ParentFont;
  177.     property ParentShowHint;
  178.     property PopupMenu;
  179.     property ShowAccelChar;
  180.     property ShowHint;
  181.     property Transparent;
  182.     property Visible;
  183. {    property WordWrap;}
  184.     property OnClick;
  185.     property OnDblClick;
  186.     property OnDragDrop;
  187.     property OnDragOver;
  188.     property OnEndDrag;
  189.     property OnMouseDown;
  190.     property OnMouseMove;
  191.     property OnMouseUp;
  192.  
  193. {$IFDEF DELPHI2_UP}
  194.     property OnStartDrag;
  195. {$ENDIF}
  196. {$IFDEF DELPHI3_UP}
  197.     property Layout;
  198. {$ENDIF}
  199. {$IFDEF DELPHI4_UP}
  200. {$ENDIF}
  201. {$IFDEF DELPHI5_UP}
  202. {$ENDIF}
  203.  
  204.   end;
  205.  
  206. const
  207.   TMULTILABEL_VERSION = 100;
  208.  
  209.   NULL = 0;
  210.  
  211.   function GetWord (var This_Line: String; Delimiter: String): String;
  212.  
  213. implementation
  214.  
  215. {------------------------------------------------------------------------------
  216.     Procedure: TMultiLabel.Create
  217.   Description: standard constructor
  218.        Author: Mat Ballard
  219.  Date created: 04/25/2000
  220. Date modified: 04/25/2000 by Mat Ballard
  221.       Purpose: sets the Caption and other Properties
  222.  Known Issues:
  223.  ------------------------------------------------------------------------------}
  224. Constructor TMultiLabel.Create(AOwner:TComponent);
  225. begin
  226.   inherited Create(AOwner);
  227.   FCaption := TStringList.Create;
  228.   FCaption.Add('TMultiLabel//clBlue psSolid');
  229.   FCaption.Add('... has many//clGreen psDash');
  230.   FCaption.Add('Colored Lines !//clRed psDot');
  231.   Color := clBtnFace;
  232.   FBorderStyle := bsSingle;
  233.   FBorderWidth := 5;
  234.   FDirection := dRight;
  235.   FLineLength := 50;
  236.   Font.Name := 'Arial';
  237.   TextEdit := nil;
  238.   MyPopup := nil;
  239. end;
  240.  
  241. {------------------------------------------------------------------------------
  242.     Procedure: TMultiLabel.Destroy
  243.   Description: standard destructor
  244.        Author: Mat Ballard
  245.  Date created: 04/25/2000
  246. Date modified: 04/25/2000 by Mat Ballard
  247.       Purpose: frees the Caption
  248.  Known Issues:
  249.  ------------------------------------------------------------------------------}
  250. Destructor TMultiLabel.Destroy;
  251. begin
  252.   FCaption.Free;
  253.   inherited Destroy;
  254. end;
  255.  
  256. {Procedure TMultiLabel.SetAutoSize(Value: Boolean);
  257. begin
  258.   FAutoSize := Value;
  259.   Refresh;
  260. end;}
  261.  
  262. {------------------------------------------------------------------------------
  263.     Procedure: TMultiLabel.SetBorderStyle
  264.   Description: standard property Set procedure
  265.        Author: Mat Ballard
  266.  Date created: 04/25/2000
  267. Date modified: 04/25/2000 by Mat Ballard
  268.       Purpose: sets the BorderStyle Property
  269.  Known Issues:
  270.  ------------------------------------------------------------------------------}
  271. Procedure TMultiLabel.SetBorderStyle(Value: TBorderStyle);
  272. begin
  273.   FBorderStyle := Value;
  274.   if (Value = bsNone)
  275.     then Canvas.Pen.Color := Parent.Brush.Color
  276.     else Canvas.Pen.Color := clBlack;
  277.   Refresh;
  278. end;
  279.  
  280. {------------------------------------------------------------------------------
  281.     Procedure: TMultiLabel.SetBorderWidth
  282.   Description: standard property Set procedure
  283.        Author: Mat Ballard
  284.  Date created: 04/25/2000
  285. Date modified: 04/25/2000 by Mat Ballard
  286.       Purpose: sets the BorderWidth Property
  287.  Known Issues:
  288.  ------------------------------------------------------------------------------}
  289. Procedure TMultiLabel.SetBorderWidth(Value: TBorderWidth);
  290. begin
  291.   FBorderWidth := Value;
  292.   Refresh;
  293. end;
  294.  
  295. {------------------------------------------------------------------------------
  296.     Procedure: TMultiLabel.SetCaption
  297.   Description: standard property Set procedure
  298.        Author: Mat Ballard
  299.  Date created: 04/25/2000
  300. Date modified: 04/25/2000 by Mat Ballard
  301.       Purpose: sets the Caption Property
  302.  Known Issues:
  303.  ------------------------------------------------------------------------------}
  304. Procedure TMultiLabel.SetCaption(Value: TStringList);
  305. begin
  306.   Caption.Assign(Value);
  307.   Refresh;
  308. end;
  309.  
  310. {------------------------------------------------------------------------------
  311.     Procedure: TMultiLabel.SetDirection
  312.   Description: standard property Set procedure
  313.        Author: Mat Ballard
  314.  Date created: 04/25/2000
  315. Date modified: 04/25/2000 by Mat Ballard
  316.       Purpose: sets the Direction Property
  317.  Known Issues:
  318.  ------------------------------------------------------------------------------}
  319. Procedure TMultiLabel.SetDirection(Value: TDirection);
  320. begin
  321.   FDirection := Value;
  322.   Refresh;
  323. end;
  324.  
  325. {------------------------------------------------------------------------------
  326.     Procedure: TMultiLabel.SetLineLength
  327.   Description: standard property Set procedure
  328.        Author: Mat Ballard
  329.  Date created: 04/25/2000
  330. Date modified: 04/25/2000 by Mat Ballard
  331.       Purpose: sets the LineLength Property
  332.  Known Issues:
  333.  ------------------------------------------------------------------------------}
  334. Procedure TMultiLabel.SetLineLength(Value: Word);
  335. begin
  336.   FLineLength := Value;
  337.   Refresh;
  338. end;
  339.  
  340. {------------------------------------------------------------------------------
  341.     Procedure: TMultiLabel.Paint
  342.   Description: standard Paint method
  343.        Author: Mat Ballard
  344.  Date created: 04/25/2000
  345. Date modified: 04/25/2000 by Mat Ballard
  346.       Purpose: Paints the multilabel, in various colors and orientations
  347.  Known Issues:
  348.  ------------------------------------------------------------------------------}
  349. Procedure TMultiLabel.Paint;
  350. const
  351.   Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  352.   WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
  353. var
  354.   i: Integer;
  355.   CharStart: Integer;
  356.   TheLine: TRect;
  357.   Rect: TRect;
  358. {$IFDEF DELPHI3_UP}
  359.   CalcRect: TRect;
  360. {$ENDIF}
  361.   DrawStyle: Longint;
  362.   TheTextHeight: Integer;
  363. begin
  364.   if (TextEdit <> nil) then
  365.   begin
  366.     TextEdit.Free;
  367.     TextEdit := nil;
  368.   end;
  369.   if (MyPopup <> nil) then
  370.   begin
  371.     MyPopup.Free;
  372.     MyPopup := nil;
  373.   end;
  374.  
  375.   Canvas.Font := Font;
  376.   SetSize;
  377.  
  378.   with Canvas do
  379.   begin
  380.     TheTextHeight := TextHeight('Wp');
  381.  
  382.     CharStart := FBorderWidth;
  383.     for i := 0 to Caption.Count-1 do
  384.     begin
  385.      if (Pos('ps', Caption.Strings[i]) > 0) then
  386.      begin
  387.        Inc(CharStart, FLineLength + FBorderWidth);
  388.        break;
  389.      end;
  390.     end;
  391.  
  392.     case FDirection of
  393.       dRight:
  394.         begin
  395. {the text:}
  396.           Rect.Left := CharStart;
  397.           Rect.Right := Width - FBorderWidth;
  398.           Rect.Top := FBorderWidth;
  399.           Rect.Bottom := Rect.Top + TheTextHeight;
  400. {the line}
  401.           TheLine.Left := FBorderWidth;
  402.           TheLine.Right := TheLine.Left + FLineLength;
  403.           TheLine.Top := FBorderWidth + TheTextHeight div 2;
  404.           TheLine.Bottom := TheLine.Top;
  405.         end;
  406.       dLeft:
  407.         begin
  408.           Rect.Right := FBorderWidth;
  409.           Rect.Left := Width - CharStart;
  410.           Rect.Top := Height - FBorderWidth;
  411.           Rect.Bottom := Rect.Top - TheTextHeight;
  412.           TheLine.Right := Width - FBorderWidth;
  413.           TheLine.Left := TheLine.Right - FLineLength;
  414.           TheLine.Top := Height - FBorderWidth - TheTextHeight div 2;
  415.           TheLine.Bottom := TheLine.Top;
  416.         end;
  417.       dUp:
  418.         begin
  419.           Rect.Left := FBorderWidth;
  420.           Rect.Right := Rect.Left + TheTextHeight;
  421.           Rect.Bottom := FBorderWidth;
  422.           Rect.Top := Height - CharStart;
  423.           TheLine.Left := FBorderWidth + TheTextHeight div 2;
  424.           TheLine.Right := TheLine.Left;
  425.           TheLine.Bottom := Height - FBorderWidth;
  426.           TheLine.Top := TheLine.Bottom - FLineLength;
  427.         end;
  428.       dDown:
  429.         begin
  430.           Rect.Left := Width - FBorderWidth;
  431.           Rect.Right := Rect.Left - TheTextHeight;
  432.           Rect.Top := CharStart;
  433.           Rect.Bottom := Height - FBorderWidth;
  434.           TheLine.Left := Width - FBorderWidth - TheTextHeight div 2;
  435.           TheLine.Right := TheLine.Left;
  436.           TheLine.Top := FBorderWidth;
  437.           TheLine.Bottom := TheLine.Top + FLineLength;
  438.         end;
  439.     end;
  440.  
  441.     if not Transparent then
  442.     begin
  443.       Brush.Color := Self.Color;
  444.       Brush.Style := bsSolid;
  445.       FillRect(ClientRect);
  446.     end;
  447.  
  448.     for i := 0 to Caption.Count-1 do
  449.     begin
  450.       Font.Color := ExtractColor(i);
  451.       {Canvas.TextOut(XStart, Y, ExtractText(i));}
  452.  
  453.  
  454.       Brush.Style := bsClear;
  455.       { DoDrawText takes care of BiDi alignments }
  456.       DrawStyle := DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment];
  457. {$IFDEF DELPHI3_UP}
  458.       { Calculate vertical layout }
  459.       if Layout <> tlTop then
  460.       begin
  461.         CalcRect := Rect;
  462.         DoDrawText(ExtractText(i), CalcRect, DrawStyle or DT_CALCRECT);
  463.         if Layout = tlBottom then OffsetRect(Rect, 0, Height - CalcRect.Bottom)
  464.         else OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);
  465.       end;
  466. {$ENDIF}
  467.       DoDrawText(ExtractText(i), Rect, DrawStyle);
  468. {draw the lines:}
  469.       Pen.Style := ExtractPenStyle(i);
  470.       Pen.Color := Font.Color;
  471.       MoveTo(TheLine.Left, TheLine.Top);
  472.       LineTo(TheLine.Right, TheLine.Bottom);
  473. {increment the rectangles:}
  474.       case FDirection of
  475.         dRight:
  476.           begin
  477.   {the text:}
  478.             Inc(Rect.Top, TheTextHeight);
  479.             Inc(Rect.Bottom, TheTextHeight);
  480.   {the line}
  481.             Inc(TheLine.Top, TheTextHeight);
  482.             Inc(TheLine.Bottom, TheTextHeight);
  483.           end;
  484.         dLeft:
  485.           begin
  486.             Dec(Rect.Top, TheTextHeight);
  487.             Dec(Rect.Bottom, TheTextHeight);
  488.             Dec(TheLine.Top, TheTextHeight);
  489.             Dec(TheLine.Bottom, TheTextHeight);
  490.           end;
  491.         dUp:
  492.           begin
  493.             Inc(Rect.Left, TheTextHeight);
  494.             Inc(Rect.Right, TheTextHeight);
  495.             Inc(TheLine.Left, TheTextHeight);
  496.             Inc(TheLine.Right, TheTextHeight);
  497.           end;
  498.         dDown:
  499.           begin
  500.             Dec(Rect.Left, TheTextHeight);
  501.             Dec(Rect.Right, TheTextHeight);
  502.             Dec(TheLine.Left, TheTextHeight);
  503.             Dec(TheLine.Right, TheTextHeight);
  504.           end;
  505.       end;
  506.     end; {for}
  507. {draw the border:}
  508.     if (BorderStyle = bsSingle) then
  509.     begin
  510.       Pen.Color := clBlack;
  511.       Pen.Style := psSolid;
  512.       Outline;
  513.     end;
  514.   end; {canvas}
  515. end;
  516.  
  517. {------------------------------------------------------------------------------
  518.      Function: TMultiLabel.ExtractPenStyle
  519.   Description: Extracts the PenStyle from the String
  520.        Author: Mat Ballard
  521.  Date created: 04/25/2000
  522. Date modified: 04/25/2000 by Mat Ballard
  523.       Purpose: see Description
  524.  Return Value: psXXX - the PenStyle
  525.  Known Issues:
  526.  ------------------------------------------------------------------------------}
  527. Function TMultiLabel.ExtractPenStyle(Index: Integer): TPenStyle;
  528. var
  529.   PenStyle: String;
  530. begin
  531.   PenStyle := FCaption.Strings[Index];
  532.   if (Pos('ps',PenStyle) > 0) then
  533.   begin
  534.     GetWord(PenStyle, 'ps');
  535.     PenStyle := 'ps' + GetWord(PenStyle, ' ');
  536.     if (PenStyle = 'psSolid') then
  537.     begin
  538.       ExtractPenStyle := psSolid;
  539.     end
  540.     else if (PenStyle = 'psDash') then
  541.     begin
  542.       ExtractPenStyle := psDash;
  543.     end
  544.     else if (PenStyle = 'psDot') then
  545.     begin
  546.       ExtractPenStyle := psDot;
  547.     end
  548.     else if (PenStyle = 'psDashDot') then
  549.     begin
  550.       ExtractPenStyle := psDashDot;
  551.     end
  552.     else if (PenStyle = 'psDashDotDot') then
  553.     begin
  554.       ExtractPenStyle := psDashDotDot;
  555.     end
  556.     else if (PenStyle = 'psInsideFrame') then
  557.     begin
  558.       ExtractPenStyle := psInsideFrame;
  559.     end
  560.     else {(PenStyle = 'psClear'}
  561.     begin
  562.       ExtractPenStyle := psClear;
  563.     end;
  564.   end
  565.   else
  566.   begin
  567.     ExtractPenStyle := psClear;
  568.   end;
  569. end;
  570.  
  571. {------------------------------------------------------------------------------
  572.      Function: TMultiLabel.ExtractColor
  573.   Description: Extracts the PenColor from the String
  574.        Author: Mat Ballard
  575.  Date created: 04/25/2000
  576. Date modified: 04/25/2000 by Mat Ballard
  577.       Purpose: see Description
  578.  Return Value: the color
  579.  Known Issues:
  580.  ------------------------------------------------------------------------------}
  581. Function TMultiLabel.ExtractColor(Index: Integer): TColor;
  582. var
  583.   StringColor: String;
  584. begin
  585.   StringColor := FCaption.Strings[Index];
  586.   if (Pos('cl',StringColor) > 0) then
  587.   begin
  588.     GetWord(StringColor, 'cl');
  589.     StringColor := 'cl' + GetWord(StringColor, ' ');
  590.     try
  591.       ExtractColor := StringToColor(StringColor);
  592.     except
  593.       ExtractColor := clBlack;
  594.     end;
  595.   end
  596.   else
  597.   begin
  598.     ExtractColor := Font.Color;
  599.   end;
  600. end;
  601.  
  602. {------------------------------------------------------------------------------
  603.      Function: TMultiLabel.ExtractText
  604.   Description: Extracts the Text from the String
  605.        Author: Mat Ballard
  606.  Date created: 04/25/2000
  607. Date modified: 04/25/2000 by Mat Ballard
  608.       Purpose: see Description
  609.  Return Value: The text to dsiplay
  610.  Known Issues:
  611.  ------------------------------------------------------------------------------}
  612. Function TMultiLabel.ExtractText(Index: Integer): String;
  613. begin
  614.   if (Pos('//',FCaption.Strings[Index]) > 0) then
  615.   begin
  616.     ExtractText := Copy(Caption.Strings[Index],
  617.                         1,
  618.                         Pos('//',Caption.Strings[Index])-1);
  619.   end
  620.   else
  621.   begin
  622.     ExtractText := Caption.Strings[Index];
  623.   end;
  624. end;
  625.  
  626. {------------------------------------------------------------------------------
  627.     Procedure: TMultiLabel.Outline
  628.   Description: Draws an outline around the text
  629.        Author: Mat Ballard
  630.  Date created: 04/25/2000
  631. Date modified: 04/25/2000 by Mat Ballard
  632.       Purpose: see Description
  633.  Known Issues:
  634.  ------------------------------------------------------------------------------}
  635. Procedure TMultiLabel.Outline;
  636. begin
  637.   with Canvas do
  638.   begin
  639.     MoveTo(0, 0);
  640.     LineTo(Width-1, 0);
  641.     LineTo(Width-1, Height-1);
  642.     LineTo(0, Height-1);
  643.     LineTo(0, 0);
  644.   end;
  645. end;
  646.  
  647. {------------------------------------------------------------------------------
  648.     Procedure: TMultiLabel.DoDrawText
  649.   Description: draws a line of text in the given rectangle
  650.        Author: Mat Ballard
  651.  Date created: 04/25/2000
  652. Date modified: 04/25/2000 by Mat Ballard
  653.       Purpose: see Description
  654.  Known Issues:
  655.  ------------------------------------------------------------------------------}
  656. procedure TMultiLabel.DoDrawText(Text: String; var Rect: TRect; Flags: Longint);
  657. var
  658.   LogRec: TLogFont;
  659.   OldFontHandle, NewFontHandle: hFont;
  660.   {H, W, X, Y: Integer;
  661.   BRect: TRect;}
  662. begin
  663.   if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and
  664.     (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  665.   {if not ShowAccelChar then Flags := Flags or DT_NOPREFIX;}
  666. {$IFDEF DELPHI3_UP}
  667.   {Flags := DrawTextBiDiModeFlags(Flags);}
  668. {$ENDIF}
  669.   {Canvas.Font := Font;}
  670.  
  671.   OldFontHandle := 0;
  672.   if (FDirection <> dRight) then
  673.   begin
  674. {create a rotated font based on the font object Font}
  675.     with Canvas do
  676.     begin
  677.       GetObject(Font.Handle, SizeOf(LogRec), Addr(LogRec));
  678.       case FDirection of
  679.         dLeft:  LogRec.lfEscapement := 1800;
  680.         dRight: LogRec.lfEscapement := 0;
  681.         dUp:    LogRec.lfEscapement := 900;
  682.         dDown:  LogRec.lfEscapement := 2700;
  683.       end;
  684.       LogRec.lfOutPrecision := OUT_DEFAULT_PRECIS;
  685.       NewFontHandle := CreateFontIndirect(LogRec);
  686.     end;
  687. {select the new font:}
  688.     OldFontHandle := SelectObject(Canvas.Handle, NewFontHandle);
  689.   end;
  690.  
  691.   if not Enabled then
  692.   begin
  693.     OffsetRect(Rect, 1, 1);
  694.     Canvas.Font.Color := clBtnHighlight;
  695.     Canvas.TextOut(Rect.Left, Rect.Top, Text);
  696.     {DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);}
  697.     OffsetRect(Rect, -1, -1);
  698.     Canvas.Font.Color := clBtnShadow;
  699.     Canvas.TextOut(Rect.Left, Rect.Top, Text);
  700.     {DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);}
  701.   end
  702.   else
  703.   begin
  704.     Canvas.TextOut(Rect.Left, Rect.Top, Text);
  705.     {DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);}
  706.   end;
  707.  
  708.   if (FDirection <> dRight) then
  709.   begin
  710. {go back to original font:}
  711.     NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle);
  712. {and delete the old one:}
  713.     DeleteObject(NewFontHandle);
  714.   end;
  715. end;
  716.  
  717. {------------------------------------------------------------------------------
  718.     Procedure: TMultiLabel.SetSize
  719.   Description: sets the width of the MultiLabel
  720.        Author: Mat Ballard
  721.  Date created: 04/25/2000
  722. Date modified: 04/25/2000 by Mat Ballard
  723.       Purpose: see Description
  724.  Known Issues:
  725.  ------------------------------------------------------------------------------}
  726. Procedure TMultiLabel.SetSize;
  727. var
  728.   i, MaxWidth: Integer;
  729.   TheTextHeight, TheTextWidth: Integer;
  730. begin
  731.   if (AutoSize) then
  732.   begin
  733.     TheTextHeight := Caption.Count * Canvas.TextHeight('Ap') +
  734.               2 * FBorderWidth;
  735.     MaxWidth := 0;
  736.     for i := 0 to Caption.Count-1 do
  737.     begin
  738.       if (Canvas.TextWidth(ExtractText(i)) > MaxWidth) then
  739.       begin
  740.         MaxWidth := Canvas.TextWidth(ExtractText(i));
  741.       end;
  742.     end;
  743.     TheTextWidth := MaxWidth + 3 * FBorderWidth;
  744.     for i := 0 to Caption.Count-1 do
  745.     begin
  746.      if (Pos('ps', Caption.Strings[i]) > 0) then
  747.      begin
  748.        Inc(TheTextWidth, FLineLength);
  749.        break;
  750.      end;
  751.     end;
  752. {take account of direction:}
  753.     if ((FDirection = dUp) or (FDirection = dDown)) then
  754.     begin
  755.       Width := TheTextHeight;
  756.       Height := TheTextWidth;
  757.     end
  758.     else
  759.     begin
  760.       Width := TheTextWidth;
  761.       Height := TheTextHeight;
  762.     end;
  763.   end;
  764. end;
  765.  
  766. {------------------------------------------------------------------------------
  767.     Procedure: TMultiLabel.DblClick
  768.   Description: standard DblClick event handler
  769.        Author: Mat Ballard
  770.  Date created: 04/25/2000
  771. Date modified: 04/25/2000 by Mat Ballard
  772.       Purpose: makes the component editable
  773.  Known Issues:
  774.  ------------------------------------------------------------------------------}
  775. Procedure TMultiLabel.DblClick;
  776. begin
  777.   Visible := FALSE;
  778.   TextEdit := TMemo.Create(Self); {.Owner}
  779.  
  780.   TextEdit.Parent := Self.Parent;
  781.   TextEdit.Top := Top;
  782.   TextEdit.Left := Left;
  783.   if ((FDirection = dRight) or (FDirection = dLeft)) then
  784.   begin
  785.     TextEdit.Height := 3*Height div 2;
  786.     TextEdit.Width := 3*Width div 2;
  787.   end
  788.   else
  789.   begin
  790.     TextEdit.Height := 3*Width div 2;
  791.     TextEdit.Width := 3*Height div 2;
  792.   end;
  793.   TextEdit.Lines.Assign(Caption);
  794.   TextEdit.ParentColor := TRUE;
  795.  
  796.   TextEdit.OnExit := EditFinished;
  797.   TextEdit.OnKeyDown := EditKeyDown;
  798.  
  799.   inherited DblClick;
  800. end;
  801.  
  802. {------------------------------------------------------------------------------
  803.     Procedure: TMultiLabel.EditFinished
  804.   Description: saves the edited text into the Caption property
  805.        Author: Mat Ballard
  806.  Date created: 04/25/2000
  807. Date modified: 04/25/2000 by Mat Ballard
  808.       Purpose: in-place editing
  809.  Known Issues:
  810.  ------------------------------------------------------------------------------}
  811. procedure TMultiLabel.EditFinished(Sender: TObject);
  812. begin
  813.   TextEdit.Visible := FALSE;
  814.   Caption.Assign(TextEdit.Lines);
  815.   Visible := TRUE;
  816. end;
  817.  
  818. {------------------------------------------------------------------------------
  819.     Procedure: TMultiLabel.EditKeyDown
  820.   Description: KeyDown event handler for in-place editing
  821.        Author: Mat Ballard
  822.  Date created: 04/25/2000
  823. Date modified: 04/25/2000 by Mat Ballard
  824.       Purpose: terminates editing when Esc pressed
  825.  Known Issues:
  826.  ------------------------------------------------------------------------------}
  827. procedure TMultiLabel.EditKeyDown(Sender: TObject;
  828.                                   var Key: Word;
  829.                                   Shift: TShiftState);
  830. begin
  831.   if (Key = VK_ESCAPE) then
  832.     EditFinished(Sender);
  833. end;
  834.  
  835. {procedure TMultiLabel.AdjustBounds;
  836. const
  837.   WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
  838. var
  839.   DC: HDC;
  840.   X: Integer;
  841.   Rect: TRect;
  842.   AAlignment: TAlignment;
  843.   i, MaxWidth: Integer;
  844. begin
  845.   if not (csReading in ComponentState) and FAutoSize then
  846.   begin
  847.     MaxWidth := 0;
  848.     for i := 0 to Caption.Count-1 do
  849.     begin
  850.       if (Length(ExtractText(i)) > MaxWidth) then
  851.       begin
  852.         MaxWidth := i;
  853.       end;
  854.     end;
  855.  
  856.     Rect.Left := 0;
  857.     Rect.Top := 0;
  858.     Rect.Width :=
  859.     Rect.Height :=
  860.     DC := GetDC(0);
  861.     Canvas.Handle := DC;
  862.     DoDrawText(ExtractText(MaxWidth),
  863.                Rect,
  864.                (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[FWordWrap]);
  865.     Canvas.Handle := 0;
  866.     ReleaseDC(0, DC);
  867.     X := Left;
  868.     AAlignment := FAlignment;
  869.     if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  870.     if AAlignment = taRightJustify then Inc(X, Width - Rect.Right);
  871.     SetBounds(X, Top, Rect.Right, Rect.Bottom);
  872.   end;
  873. end;}
  874.  
  875.  
  876. Function GetWord (var This_Line: String; Delimiter: String): String;
  877. var
  878.   Delimiter_Position: Integer;
  879. begin
  880.   Delimiter_Position := Pos(Delimiter, This_Line);
  881.   If (Delimiter_Position > 0) Then
  882.   begin
  883.     GetWord := Copy(This_Line, 1, Delimiter_Position-1);
  884.     This_Line := Copy(This_Line, Delimiter_Position + Length(Delimiter), Length(This_Line));
  885.   end
  886.   Else
  887.   begin
  888.     GetWord := This_Line;
  889.     This_Line := '';
  890.   end;
  891. end;
  892.  
  893. end.
  894.