WrapButton - component with wordwrap, depresses when clicked, and has colors.

[bobonwhidbey]

I often find I need a button-like component that can wordwrap, e.g. when you switch from English to German you often need more space. I also want a button that looks like it's being depressed when you click on it. And finally, you can never have too many colors.

The technique is to put a TLabel on top of a TPanel, thereby using the wordwrap and other properties of the TLabel.

I would appreciated any suggestions on how to improve this component. Thanks.

Code: Pascal  [Select][+][-]

1. unit WrapButton;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Windows, Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
9.   LMessages, StdCtrls, ExtCtrls;
10.  
11. type
12.   TWrapButton = class(TCustomPanel)
13.   private { Private declarations }
14.     procedure SetCaption(const Value: string);
15.   protected { Protected declarations }
16.     FLab: TLabel;
17.     FCaption: string;
18.     procedure MoveLab(Down: boolean);
19.   public { Public declarations }
20.     constructor Create(AOwner: TComponent); override;
21.     destructor Destroy; override;
22.     procedure ButMouseDown(Sender: TObject; Button: TMouseButton;
23.       Shift: TShiftState; X, Y: integer);
24.     procedure ButMouseUp(Sender: TObject; Button: TMouseButton;
25.       Shift: TShiftState; X, Y: integer);
26.     property Caption: string read FCaption write SetCaption;
27.     procedure PanResize(Sender: TObject);
28.   published
29.     property Lab: TLabel read FLab;
30.     property Align;
31.     property Alignment;
32.     property Anchors;
33.     property BevelInner;
34.     property BevelOuter;
35.     property BevelWidth;
36.     property Enabled;
37.     property TabOrder;
38.     property TabStop;
39.     property Visible;
40.     property OnClick;
41.     property OnDblClick;
42.     property OnEnter;
43.     property OnExit;
44.     property OnMouseDown;
45.     property OnMouseMove;
46.     property OnMouseUp;
47.     property OnResize;
48.   end;
49.  
50. procedure Register;
51.  
52. implementation
53.  
54. procedure Register;
55. begin
56.   //   {$I WrapButton_icon.lrs} // you have to provide your own LRS file
57.   RegisterComponents('Standard', [TWrapButton]);
58. end;
59.  
60. constructor TWrapButton.Create(AOwner: TComponent);
61. begin
62.   inherited Create(AOwner);
63.   Height := 40;
64.   Width := 100;
65.   FCaption := '';
66.   BevelWidth := 3;
67.   FLab := TLabel.Create(Self);
68.   with FLab do begin
69.     SetSubComponent(True);
70.     Parent := self;
71.     left := BevelWidth + 1;
72.     top := BevelWidth + 1;
73.     FCaption := 'Panel Button';
74.     Height := self.Height - BevelWidth - 1;
75.     Width := self.Width - BevelWidth - 1;
76.     Alignment := taCenter;
77.     AutoSize := False;
78.     Caption := 'Wrap Button';
79. // you may want to define these initial values
80.     //    color := clBtnFace;
81.     //    Font.Name := 'MS Sans Serif';
82.     //    Font.Size := 10;
83.     //    Font.Style := [fsBold];
84.     Layout := tlCenter;
85.     WordWrap := True;
86.     Transparent := True;
87.     Visible := True;
88.     OnMouseDown := @ButMouseDown;
89.     OnMouseUp := @ButMouseUp;
90.   end;
91.   OnResize := @PanResize;
92. end;
93.  
94. destructor TWrapButton.Destroy;
95. begin
96.   inherited Destroy;
97. end;
98.  
99. procedure TWrapButton.SetCaption(const Value: string);
100. begin
101.   if Value <> FCaption then begin
102.     FCaption := Value;
103.     Lab.Caption := Value;
104.   end;
105. end;
106.  
107. procedure TWrapButton.MoveLab(Down: boolean);
108. const
109.   Jump = 1;  // pixel distance moved right and down
110. var
111.   x: integer;
112. begin
113.   if Down then
114.     x := Jump
115.   else
116.     x := -Jump;
117.   Lab.top := BevelWidth + x + 1;
118.   Lab.left := BevelWidth + x + 1;
119. end;
120.  
121. procedure TWrapButton.PanResize(Sender: TObject);
122. begin
123.   FLab.left := BevelWidth;
124.   FLab.top := BevelWidth;
125.   FLab.Height := self.Height - 2 * BevelWidth - 1;
126.   FLab.Width := self.Width - 2 * BevelWidth - 1;
127. end;
128.  
129. procedure TWrapButton.ButMouseDown(Sender: TObject; Button: TMouseButton;
130.   Shift: TShiftState; X, Y: integer);
131. begin
132.   BevelOuter := bvLowered;
133.   MoveLab(True);
134. end;
135.  
136.  
137. procedure TWrapButton.ButMouseUp(Sender: TObject; Button: TMouseButton;
138.   Shift: TShiftState; X, Y: integer);
139. begin
140.   BevelOuter := bvRaised;
141.   MoveLab(False);
142. end;
143.  
144. end.
145.  

[frakno]

I solved the multiline feature with my advanced TButton.
When multiline-property is checked then the dummy-char '~' in caption
is changed to an lineending.

Code: Pascal  [Select][+][-]

1. unit fButton;  {$mode objfpc}{$H+}
2.   interface
3.     uses Classes, Controls, Dialogs, Forms, Graphics, lcltype{ wegen*Multiline }, LResources, Messages,
4.       StdCtrls, SysUtils, Windows;
5.  
6.     type EBtnVisibility = ( btvNoChange, btvVisible, btvInvisible );  { Enumeration für die Prozedur Setze (Sichtbarkeit) }
7.     type TfButton = class( TButton )
8.       private FMultiline : Boolean;                         { wegen*Multiline }
9.               function  GetCaption: String;                 { wegen*Multiline }
10.               procedure SetCaption(const Value: String);    { wegen*Multiline }
11.               procedure SetMultiline(const Value: Boolean); { wegen*Multiline }
12.       protected
13.       public
14.         { Prüft ob ein bestimmtes Bit im Tag-Integer gesetzt ist und gibt True oder False zurück }
15.         function    BitExists( BitNr : Byte ) : Boolean;
16.  
17.         function    CaptionToInt : Integer;
18.  
19.         { Löscht alle gesetzten Bits im Tag-Integer }
20.         procedure   ClearBits;
21.         procedure   CreateParams( var params: TCreateParams); override;  { wegen*Multiline }
22.         constructor Create(aOwner: TComponent); override;                { wegen*Multiline }
23.         { Setzt ein bestimmtes Bit im Tag-Integer }
24.         procedure   SetzeBit( BitNr : Byte; bvVisibility : EBtnVisibility = btvNoChange );
25.  
26.         procedure   ToInvisible;
27.         procedure   ToVisible;
28.  
29.       published
30.         { Wenn Multiline = True, dann wird das Zeichen ~ als Zeilenumbruch interpretiert }
31.         property    Multiline: Boolean read FMultiline write SetMultiline default True;
32.         property    Caption: String read GetCaption write SetCaption;
33.       end;
34.  
35.     procedure Register;
36.  
37.   implementation
38.  
39.     procedure   Register; begin {$I fbutton_icon.lrs} RegisterComponents('fCtrls',[TfButton]); end;
40.  
41.     constructor TfButton.Create(aOwner: TComponent); begin inherited; FMultiline := True; end;   { wegen*Multiline }
42.  
43.     function    TfButton.BitExists( BitNr : Byte ) : Boolean; begin Result  := ( ( Tag shr BitNr) and 1 ) = 1; end;
44.  
45.     function    TfButton.CaptionToInt : Integer;
46.       begin
47.         Result :=  StrToIntDef(  Caption, 0 );
48.       end;
49.  
50.     procedure   TfButton.ClearBits; begin Tag := 0; end;
51.  
52.     procedure   TfButton.SetMultiline(const Value: Boolean);    { wegen*Multiline }
53.       begin if FMultiline <> Value then begin
54.               FMultiline := Value;
55.               RecreateWnd(Self);
56.             end;
57.       end;
58.  
59.     procedure   TfButton.CreateParams(var params: TCreateParams);    { wegen*Multiline }
60.     begin
61.       inherited;
62.       if FMultiline then
63.         params.Style := params.Style or BS_MULTILINE;
64.     end;
65.  
66.     function    TfButton.GetCaption: String;                          { wegen*Multiline }
67.     begin
68.       Result := Stringreplace( inherited Caption, #13, '~', [rfReplaceAll] );
69.     end;
70.  
71.     procedure   TfButton.SetCaption(const Value: String);            { wegen*Multiline }
72.     begin
73.       if value <> Caption then begin
74.               self.Multiline := True;
75.         inherited Caption := Stringreplace( value, '~', #13, [rfReplaceAll] );
76.         Invalidate;
77.       end;
78.       self.Multiline := True;
79.     end;
80.  
81.     procedure    TfButton.SetzeBit( BitNr : Byte; bvVisibility : EBtnVisibility = btvNoChange );
82.       begin
83.         Tag := Tag or ( 1 shl BitNr );
84.         case bvVisibility of
85.           btvVisible   : begin Visible :=  True;  end;
86.           btvInvisible : begin Visible :=  False; end;
87.         end;
88.       end;
89.  
90.     procedure   TfButton.ToInvisible; begin Visible := False; end;
91.  
92.     procedure   TfButton.ToVisible;   begin Visible := True; end;
93.  
94. end.                  
95.  

[wp]

This hack makes every TButton a multi-line button. It is important that the unit containing the "new TButton" is behind StdCtrls in the uses list.

Code: Pascal  [Select][+][-]

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, LCLType;
9.  
10. type
11.   TButton = class(StdCtrls.TButton)
12.   protected
13.     procedure CreateParams(var Params: TCreateParams); override;
14.   end;
15.  
16.   { TForm1 }
17.   TForm1 = class(TForm)
18.     Button1: TButton;
19.     procedure FormCreate(Sender: TObject);
20.   private
21.     { private declarations }
22.   public
23.     { public declarations }
24.   end;
25.  
26. var
27.   Form1: TForm1;
28.  
29. implementation
30.  
31. {$R *.lfm}
32.  
33. const
34.   BS_MULTILINE = $2000;
35.  
36. { TForm1 }
37.  
38. procedure TForm1.FormCreate(Sender: TObject);
39. begin
40.   //Button1.caption := 'Line 1'#13#10'Line 2';
41.   Button1.Caption := StringReplace(Button1.Caption, '\n', LineEnding, [rfReplaceAll]);
42. end;
43.  
44. procedure TButton.CreateParams(var Params: TCreateParams);
45. begin
46.   inherited;
47.   Params.Style := Params.Style or BS_MULTILINE;
48. end;
49.  
50. end.  

@bobonwhidbey: In your component, the label is not needed any more in Laz trunk where the caption of the panel can be wordwrapped itself by setting its new property WordWrap to true. With BorderWidth you can control how close the text can get to the border before a wordwrap occurs.

[bobonwhidbey]

wp, where can I find out more about "Laz trunk". I have the impression that it's a site where developmental versions of Laz can be found - and also improved.

[wp]

Laz trunk is the development version, yes. Its current version number is 1.7. You normally download the sources via svn (http://svn.freepascal.org/svn/lazarus/trunk), or you could also try to find a snapshot (e.g. http://mirrors.iwi.me/lazarus/snapshots/ contains one built this night). Then you must compile Lazarus from these sources - please seek the wiki for instructions.

[ASerge]

This hack makes every TButton a multi-line button. It is important that the unit containing the "new TButton" is behind StdCtrls in the uses list.

In Windows buttons can apply new style at any time. So, you can use function like this:

Code: Pascal  [Select][+][-]

1. procedure SetButtonWordwrap(Button: TButtonControl);
2. var
3.   hBtn: HWND;
4. begin
5.   hBtn := Button.Handle;
6.   SetWindowLong(hBtn, GWL_STYLE, GetWindowLong(hBtn, GWL_STYLE) or BS_MULTILINE);
7. end;
8.