home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kompon / d123456 / CHEMPLOT.ZIP / Misc / Mlabel.pas < prev    next >
Pascal/Delphi Source File  |  2001-07-26  |  27KB  |  885 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.   TheTextHeight := Canvas.TextHeight('Wp');
  379.  
  380.   CharStart := FBorderWidth;
  381.   for i := 0 to Caption.Count-1 do
  382.   begin
  383.    if (Pos('ps', Caption.Strings[i]) > 0) then
  384.    begin
  385.      Inc(CharStart, FLineLength + FBorderWidth);
  386.      break;
  387.    end;
  388.   end;
  389.  
  390.   case FDirection of
  391.     dRight:
  392.       begin
  393. {the text:}
  394.         Rect.Left := CharStart;
  395.         Rect.Right := Width - FBorderWidth;
  396.         Rect.Top := FBorderWidth;
  397.         Rect.Bottom := Rect.Top + TheTextHeight;
  398. {the line}
  399.         TheLine.Left := FBorderWidth;
  400.         TheLine.Right := TheLine.Left + FLineLength;
  401.         TheLine.Top := FBorderWidth + TheTextHeight div 2;
  402.         TheLine.Bottom := TheLine.Top;
  403.       end;
  404.     dLeft:
  405.       begin
  406.         Rect.Right := FBorderWidth;
  407.         Rect.Left := Width - CharStart;
  408.         Rect.Top := Height - FBorderWidth;
  409.         Rect.Bottom := Rect.Top - TheTextHeight;
  410.         TheLine.Right := Width - FBorderWidth;
  411.         TheLine.Left := TheLine.Right - FLineLength;
  412.         TheLine.Top := Height - FBorderWidth - TheTextHeight div 2;
  413.         TheLine.Bottom := TheLine.Top;
  414.       end;
  415.     dUp:
  416.       begin
  417.         Rect.Left := FBorderWidth;
  418.         Rect.Right := Rect.Left + TheTextHeight;
  419.         Rect.Bottom := FBorderWidth;
  420.         Rect.Top := Height - CharStart;
  421.         TheLine.Left := FBorderWidth + TheTextHeight div 2;
  422.         TheLine.Right := TheLine.Left;
  423.         TheLine.Bottom := Height - FBorderWidth;
  424.         TheLine.Top := TheLine.Bottom - FLineLength;
  425.       end;
  426.     dDown:
  427.       begin
  428.         Rect.Left := Width - FBorderWidth;
  429.         Rect.Right := Rect.Left - TheTextHeight;
  430.         Rect.Top := CharStart;
  431.         Rect.Bottom := Height - FBorderWidth;
  432.         TheLine.Left := Width - FBorderWidth - TheTextHeight div 2;
  433.         TheLine.Right := TheLine.Left;
  434.         TheLine.Top := FBorderWidth;
  435.         TheLine.Bottom := TheLine.Top + FLineLength;
  436.       end;
  437.   end;
  438.  
  439.   if not Transparent then
  440.   begin
  441.     Canvas.Brush.Color := Self.Color;
  442.     Canvas.Brush.Style := bsSolid;
  443.     Canvas.FillRect(ClientRect);
  444.   end;
  445.  
  446.   for i := 0 to Caption.Count-1 do
  447.   begin
  448.     Canvas.Font.Color := ExtractColor(i);
  449.     {Canvas.TextOut(XStart, Y, ExtractText(i));}
  450.  
  451.  
  452.     Canvas.Brush.Style := bsClear;
  453.     { DoDrawText takes care of BiDi alignments }
  454.     DrawStyle := DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment];
  455. {$IFDEF DELPHI3_UP}
  456.     { Calculate vertical layout }
  457.     if Layout <> tlTop then
  458.     begin
  459.       CalcRect := Rect;
  460.       DoDrawText(ExtractText(i), CalcRect, DrawStyle or DT_CALCRECT);
  461.       if Layout = tlBottom then OffsetRect(Rect, 0, Height - CalcRect.Bottom)
  462.       else OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);
  463.     end;
  464. {$ENDIF}
  465.     DoDrawText(ExtractText(i), Rect, DrawStyle);
  466. {draw the lines:}
  467.     Canvas.Pen.Style := ExtractPenStyle(i);
  468.     Canvas.Pen.Color := Font.Color;
  469.     Canvas.MoveTo(TheLine.Left, TheLine.Top);
  470.     Canvas.LineTo(TheLine.Right, TheLine.Bottom);
  471. {increment the rectangles:}
  472.     case FDirection of
  473.       dRight:
  474.         begin
  475. {the text:}
  476.           Inc(Rect.Top, TheTextHeight);
  477.           Inc(Rect.Bottom, TheTextHeight);
  478. {the line}
  479.           Inc(TheLine.Top, TheTextHeight);
  480.           Inc(TheLine.Bottom, TheTextHeight);
  481.         end;
  482.       dLeft:
  483.         begin
  484.           Dec(Rect.Top, TheTextHeight);
  485.           Dec(Rect.Bottom, TheTextHeight);
  486.           Dec(TheLine.Top, TheTextHeight);
  487.           Dec(TheLine.Bottom, TheTextHeight);
  488.         end;
  489.       dUp:
  490.         begin
  491.           Inc(Rect.Left, TheTextHeight);
  492.           Inc(Rect.Right, TheTextHeight);
  493.           Inc(TheLine.Left, TheTextHeight);
  494.           Inc(TheLine.Right, TheTextHeight);
  495.         end;
  496.       dDown:
  497.         begin
  498.           Dec(Rect.Left, TheTextHeight);
  499.           Dec(Rect.Right, TheTextHeight);
  500.           Dec(TheLine.Left, TheTextHeight);
  501.           Dec(TheLine.Right, TheTextHeight);
  502.         end;
  503.     end;
  504.   end; {for}
  505. {draw the border:}
  506.   if (BorderStyle = bsSingle) then
  507.   begin
  508.     Canvas.Pen.Color := clBlack;
  509.     Canvas.Pen.Style := psSolid;
  510.     Outline;
  511.   end;
  512. end;
  513.  
  514. {------------------------------------------------------------------------------
  515.      Function: TMultiLabel.ExtractPenStyle
  516.   Description: Extracts the PenStyle from the String
  517.        Author: Mat Ballard
  518.  Date created: 04/25/2000
  519. Date modified: 04/25/2000 by Mat Ballard
  520.       Purpose: see Description
  521.  Return Value: psXXX - the PenStyle
  522.  Known Issues:
  523.  ------------------------------------------------------------------------------}
  524. Function TMultiLabel.ExtractPenStyle(Index: Integer): TPenStyle;
  525. var
  526.   PenStyle: String;
  527. begin
  528.   PenStyle := FCaption.Strings[Index];
  529.   if (Pos('ps',PenStyle) > 0) then
  530.   begin
  531.     GetWord(PenStyle, 'ps');
  532.     PenStyle := 'ps' + GetWord(PenStyle, ' ');
  533.     if (PenStyle = 'psSolid') then
  534.     begin
  535.       ExtractPenStyle := psSolid;
  536.     end
  537.     else if (PenStyle = 'psDash') then
  538.     begin
  539.       ExtractPenStyle := psDash;
  540.     end
  541.     else if (PenStyle = 'psDot') then
  542.     begin
  543.       ExtractPenStyle := psDot;
  544.     end
  545.     else if (PenStyle = 'psDashDot') then
  546.     begin
  547.       ExtractPenStyle := psDashDot;
  548.     end
  549.     else if (PenStyle = 'psDashDotDot') then
  550.     begin
  551.       ExtractPenStyle := psDashDotDot;
  552.     end
  553.     else if (PenStyle = 'psInsideFrame') then
  554.     begin
  555.       ExtractPenStyle := psInsideFrame;
  556.     end
  557.     else {(PenStyle = 'psClear'}
  558.     begin
  559.       ExtractPenStyle := psClear;
  560.     end;
  561.   end
  562.   else
  563.   begin
  564.     ExtractPenStyle := psClear;
  565.   end;
  566. end;
  567.  
  568. {------------------------------------------------------------------------------
  569.      Function: TMultiLabel.ExtractColor
  570.   Description: Extracts the PenColor from the String
  571.        Author: Mat Ballard
  572.  Date created: 04/25/2000
  573. Date modified: 04/25/2000 by Mat Ballard
  574.       Purpose: see Description
  575.  Return Value: the color
  576.  Known Issues:
  577.  ------------------------------------------------------------------------------}
  578. Function TMultiLabel.ExtractColor(Index: Integer): TColor;
  579. var
  580.   StringColor: String;
  581. begin
  582.   StringColor := FCaption.Strings[Index];
  583.   if (Pos('cl',StringColor) > 0) then
  584.   begin
  585.     GetWord(StringColor, 'cl');
  586.     StringColor := 'cl' + GetWord(StringColor, ' ');
  587.     try
  588.       ExtractColor := StringToColor(StringColor);
  589.     except
  590.       ExtractColor := clBlack;
  591.     end;
  592.   end
  593.   else
  594.   begin
  595.     ExtractColor := Font.Color;
  596.   end;
  597. end;
  598.  
  599. {------------------------------------------------------------------------------
  600.      Function: TMultiLabel.ExtractText
  601.   Description: Extracts the Text from the String
  602.        Author: Mat Ballard
  603.  Date created: 04/25/2000
  604. Date modified: 04/25/2000 by Mat Ballard
  605.       Purpose: see Description
  606.  Return Value: The text to dsiplay
  607.  Known Issues:
  608.  ------------------------------------------------------------------------------}
  609. Function TMultiLabel.ExtractText(Index: Integer): String;
  610. begin
  611.   if (Pos('//',FCaption.Strings[Index]) > 0) then
  612.   begin
  613.     ExtractText := Copy(Caption.Strings[Index],
  614.                         1,
  615.                         Pos('//',Caption.Strings[Index])-1);
  616.   end
  617.   else
  618.   begin
  619.     ExtractText := Caption.Strings[Index];
  620.   end;
  621. end;
  622.  
  623. {------------------------------------------------------------------------------
  624.     Procedure: TMultiLabel.Outline
  625.   Description: Draws an outline around the text
  626.        Author: Mat Ballard
  627.  Date created: 04/25/2000
  628. Date modified: 04/25/2000 by Mat Ballard
  629.       Purpose: see Description
  630.  Known Issues:
  631.  ------------------------------------------------------------------------------}
  632. Procedure TMultiLabel.Outline;
  633. begin
  634.   Canvas.MoveTo(0, 0);
  635.   Canvas.LineTo(Width-1, 0);
  636.   Canvas.LineTo(Width-1, Height-1);
  637.   Canvas.LineTo(0, Height-1);
  638.   Canvas.LineTo(0, 0);
  639. end;
  640.  
  641. {------------------------------------------------------------------------------
  642.     Procedure: TMultiLabel.DoDrawText
  643.   Description: draws a line of text in the given rectangle
  644.        Author: Mat Ballard
  645.  Date created: 04/25/2000
  646. Date modified: 04/25/2000 by Mat Ballard
  647.       Purpose: see Description
  648.  Known Issues:
  649.  ------------------------------------------------------------------------------}
  650. procedure TMultiLabel.DoDrawText(Text: String; var Rect: TRect; Flags: Longint);
  651. var
  652.   LogRec: TLogFont;
  653.   OldFontHandle, NewFontHandle: hFont;
  654.   {H, W, X, Y: Integer;
  655.   BRect: TRect;}
  656. begin
  657.   if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and
  658.     (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  659.   {if not ShowAccelChar then Flags := Flags or DT_NOPREFIX;}
  660. {$IFDEF DELPHI3_UP}
  661.   {Flags := DrawTextBiDiModeFlags(Flags);}
  662. {$ENDIF}
  663.   {Canvas.Font := Font;}
  664.  
  665.   OldFontHandle := 0;
  666.   if (FDirection <> dRight) then
  667.   begin
  668. {create a rotated font based on the font object Font}
  669.     GetObject(Font.Handle, SizeOf(LogRec), Addr(LogRec));
  670.     case FDirection of
  671.       dLeft:  LogRec.lfEscapement := 1800;
  672.       dRight: LogRec.lfEscapement := 0;
  673.       dUp:    LogRec.lfEscapement := 900;
  674.       dDown:  LogRec.lfEscapement := 2700;
  675.     end;
  676.     LogRec.lfOutPrecision := OUT_DEFAULT_PRECIS;
  677.     NewFontHandle := CreateFontIndirect(LogRec);
  678. {select the new font:}
  679.     OldFontHandle := SelectObject(Canvas.Handle, NewFontHandle);
  680.   end;
  681.  
  682.   if not Enabled then
  683.   begin
  684.     OffsetRect(Rect, 1, 1);
  685.     Canvas.Font.Color := clBtnHighlight;
  686.     Canvas.TextOut(Rect.Left, Rect.Top, Text);
  687.     {DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);}
  688.     OffsetRect(Rect, -1, -1);
  689.     Canvas.Font.Color := clBtnShadow;
  690.     Canvas.TextOut(Rect.Left, Rect.Top, Text);
  691.     {DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);}
  692.   end
  693.   else
  694.   begin
  695.     Canvas.TextOut(Rect.Left, Rect.Top, Text);
  696.     {DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);}
  697.   end;
  698.  
  699.   if (FDirection <> dRight) then
  700.   begin
  701. {go back to original font:}
  702.     NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle);
  703. {and delete the old one:}
  704.     DeleteObject(NewFontHandle);
  705.   end;
  706. end;
  707.  
  708. {------------------------------------------------------------------------------
  709.     Procedure: TMultiLabel.SetSize
  710.   Description: sets the width of the MultiLabel
  711.        Author: Mat Ballard
  712.  Date created: 04/25/2000
  713. Date modified: 04/25/2000 by Mat Ballard
  714.       Purpose: see Description
  715.  Known Issues:
  716.  ------------------------------------------------------------------------------}
  717. Procedure TMultiLabel.SetSize;
  718. var
  719.   i, MaxWidth: Integer;
  720.   TheTextHeight, TheTextWidth: Integer;
  721. begin
  722.   if (AutoSize) then
  723.   begin
  724.     TheTextHeight := Caption.Count * Canvas.TextHeight('Ap') +
  725.               2 * FBorderWidth;
  726.     MaxWidth := 0;
  727.     for i := 0 to Caption.Count-1 do
  728.     begin
  729.       if (Canvas.TextWidth(ExtractText(i)) > MaxWidth) then
  730.       begin
  731.         MaxWidth := Canvas.TextWidth(ExtractText(i));
  732.       end;
  733.     end;
  734.     TheTextWidth := MaxWidth + 3 * FBorderWidth;
  735.     for i := 0 to Caption.Count-1 do
  736.     begin
  737.      if (Pos('ps', Caption.Strings[i]) > 0) then
  738.      begin
  739.        Inc(TheTextWidth, FLineLength);
  740.        break;
  741.      end;
  742.     end;
  743. {take account of direction:}
  744.     if ((FDirection = dUp) or (FDirection = dDown)) then
  745.     begin
  746.       Width := TheTextHeight;
  747.       Height := TheTextWidth;
  748.     end
  749.     else
  750.     begin
  751.       Width := TheTextWidth;
  752.       Height := TheTextHeight;
  753.     end;
  754.   end;
  755. end;
  756.  
  757. {------------------------------------------------------------------------------
  758.     Procedure: TMultiLabel.DblClick
  759.   Description: standard DblClick event handler
  760.        Author: Mat Ballard
  761.  Date created: 04/25/2000
  762. Date modified: 04/25/2000 by Mat Ballard
  763.       Purpose: makes the component editable
  764.  Known Issues:
  765.  ------------------------------------------------------------------------------}
  766. Procedure TMultiLabel.DblClick;
  767. begin
  768.   Visible := FALSE;
  769.   TextEdit := TMemo.Create(Self); {.Owner}
  770.  
  771.   TextEdit.Parent := Self.Parent;
  772.   TextEdit.Top := Top;
  773.   TextEdit.Left := Left;
  774.   if ((FDirection = dRight) or (FDirection = dLeft)) then
  775.   begin
  776.     TextEdit.Height := 3*Height div 2;
  777.     TextEdit.Width := 3*Width div 2;
  778.   end
  779.   else
  780.   begin
  781.     TextEdit.Height := 3*Width div 2;
  782.     TextEdit.Width := 3*Height div 2;
  783.   end;
  784.   TextEdit.Lines.Assign(Caption);
  785.   TextEdit.ParentColor := TRUE;
  786.  
  787.   TextEdit.OnExit := EditFinished;
  788.   TextEdit.OnKeyDown := EditKeyDown;
  789.  
  790.   inherited DblClick;
  791. end;
  792.  
  793. {------------------------------------------------------------------------------
  794.     Procedure: TMultiLabel.EditFinished
  795.   Description: saves the edited text into the Caption property
  796.        Author: Mat Ballard
  797.  Date created: 04/25/2000
  798. Date modified: 04/25/2000 by Mat Ballard
  799.       Purpose: in-place editing
  800.  Known Issues:
  801.  ------------------------------------------------------------------------------}
  802. procedure TMultiLabel.EditFinished(Sender: TObject);
  803. begin
  804.   TextEdit.Visible := FALSE;
  805.   Caption.Assign(TextEdit.Lines);
  806.   Visible := TRUE;
  807. end;
  808.  
  809. {------------------------------------------------------------------------------
  810.     Procedure: TMultiLabel.EditKeyDown
  811.   Description: KeyDown event handler for in-place editing
  812.        Author: Mat Ballard
  813.  Date created: 04/25/2000
  814. Date modified: 04/25/2000 by Mat Ballard
  815.       Purpose: terminates editing when Esc pressed
  816.  Known Issues:
  817.  ------------------------------------------------------------------------------}
  818. procedure TMultiLabel.EditKeyDown(Sender: TObject;
  819.                                   var Key: Word;
  820.                                   Shift: TShiftState);
  821. begin
  822.   if (Key = VK_ESCAPE) then
  823.     EditFinished(Sender);
  824. end;
  825.  
  826. {procedure TMultiLabel.AdjustBounds;
  827. const
  828.   WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
  829. var
  830.   DC: HDC;
  831.   X: Integer;
  832.   Rect: TRect;
  833.   AAlignment: TAlignment;
  834.   i, MaxWidth: Integer;
  835. begin
  836.   if not (csReading in ComponentState) and FAutoSize then
  837.   begin
  838.     MaxWidth := 0;
  839.     for i := 0 to Caption.Count-1 do
  840.     begin
  841.       if (Length(ExtractText(i)) > MaxWidth) then
  842.       begin
  843.         MaxWidth := i;
  844.       end;
  845.     end;
  846.  
  847.     Rect.Left := 0;
  848.     Rect.Top := 0;
  849.     Rect.Width :=
  850.     Rect.Height :=
  851.     DC := GetDC(0);
  852.     Canvas.Handle := DC;
  853.     DoDrawText(ExtractText(MaxWidth),
  854.                Rect,
  855.                (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[FWordWrap]);
  856.     Canvas.Handle := 0;
  857.     ReleaseDC(0, DC);
  858.     X := Left;
  859.     AAlignment := FAlignment;
  860.     if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  861.     if AAlignment = taRightJustify then Inc(X, Width - Rect.Right);
  862.     SetBounds(X, Top, Rect.Right, Rect.Bottom);
  863.   end;
  864. end;}
  865.  
  866.  
  867. Function GetWord (var This_Line: String; Delimiter: String): String;
  868. var
  869.   Delimiter_Position: Integer;
  870. begin
  871.   Delimiter_Position := Pos(Delimiter, This_Line);
  872.   If (Delimiter_Position > 0) Then
  873.   begin
  874.     GetWord := Copy(This_Line, 1, Delimiter_Position-1);
  875.     This_Line := Copy(This_Line, Delimiter_Position + Length(Delimiter), Length(This_Line));
  876.   end
  877.   Else
  878.   begin
  879.     GetWord := This_Line;
  880.     This_Line := '';
  881.   end;
  882. end;
  883.  
  884. end.
  885.