Contributor: GARRET WILSON
{*******************************************************************************
TRichButton
Copyright © 1997 Mentor Computer Solutions
Version 1.0 revised February 2, 1997
Author: Garret Wilson
Garret@MentorComputer.com
Company: Mentor Computer Solutions
RR 2 Box 246
Chelsea, OK 74016 USA
(918) 789-2734
http://www.MentorComputer.com
Status: Freeware. Source may be redistributed in whole, providing that
the copyright information is also included.
Description: TRichButton provides a button that can include rich text,
including bold, italics, different fonts, etc. To use
TRichButton, access the Lines, Font, Color, DefAttributes,
SelAttributes, and Paragraph properties, which function
identically to those that come with the standard TRichEdit
control.
Acknowledgements: TRichButton was developed in part by referring to the
Borland source code for TCustomPanel and TRichEdit. Some
features of TRichButton originated from ideas implemented in
TTransBitmap, which is Copyright © 1996 Alan GARNY,
gry@physiol.ox.ac.uk, http://www.physiol.ox.ac.uk/~gry
and these instances are indicated.
*******************************************************************************}
unit RichButton;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ComCtrls, ExtCtrls;
type
TRichButtonState = (stUp, stDown, stDisabled);
TRichButton = class(TCustomControl)
private
FAlignment: TAlignment; {storage for properties}
FAllowDown: Boolean;
FBevelInner: TPanelBevel;
FBevelOuter: TPanelBevel;
FBevelWidth: TBevelWidth;
FBorderWidth: TBorderWidth;
FBorderStyle: TBorderStyle;
FFocus: Boolean;
FFocusColor: TColor;
FFocusWidth: TWidth;
FFullRepaint: Boolean;
FLocked: Boolean;
FState: TRichButtonState;
FOnResize: TNotifyEvent;
FSelAttributes: TTextAttributes;
FDefAttributes: TTextAttributes;
FParagraph: TParaAttributes;
HasFocus:Boolean; {variables used internally}
MouseCaught:Boolean;
OrigState:TRichButtonState;
RichEdit:TRichEdit;
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
procedure CMIsToolControl(var Message: TMessage); message CM_ISTOOLCONTROL;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure SetAlignment(Value: TAlignment);
procedure SetAllowDown(Value:Boolean); {modified from TTransBitmap}
procedure SetBevelInner(Value: TPanelBevel);
procedure SetBevelOuter(Value: TPanelBevel);
procedure SetBevelWidth(Value: TBevelWidth);
procedure SetBorderWidth(Value: TBorderWidth);
procedure SetBorderStyle(Value: TBorderStyle);
procedure SetFocus(Value:Boolean); {modified from TTransBitmap}
procedure SetFocusColor(Value:TColor); {modified from TTransBitmap}
procedure SetFocusWidth(Value:TWidth); {modified from TTransBitmap}
function GetLines:TStrings;
procedure SetLines(Value:TStrings);
procedure SetState(Value:TRichButtonState); {modified from TTransBitmap}
procedure ReadData(Reader: TReader);
{internal routines}
function GetWorkRect:TRect; {modified from TTransBitmap}
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
procedure Paint; override;
procedure Resize; dynamic;
property FullRepaint: Boolean read FFullRepaint write FFullRepaint default True;
public
constructor Create(AOwner: TComponent); override;
property DefAttributes:TTextAttributes read FDefAttributes write FDefAttributes; {properties stored in TRichEdit}
property SelAttributes:TTextAttributes read FSelAttributes write FSelAttributes;
property Paragraph:TParaAttributes read FParagraph;
published
property Align;
property Alignment:TAlignment read FAlignment write SetAlignment default taCenter;
property AllowDown:Boolean read FAllowDown write SetAllowDown default False;
property BevelInner:TPanelBevel read FBevelInner write SetBevelInner default bvNone;
property BevelOuter:TPanelBevel read FBevelOuter write SetBevelOuter default bvRaised;
property BevelWidth:TBevelWidth read FBevelWidth write SetBevelWidth default 2;
property BorderWidth:TBorderWidth read FBorderWidth write SetBorderWidth default 0;
property BorderStyle:TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
property DragCursor;
property DragMode;
property Enabled;
property Color default clBtnFace;
property Ctl3D;
property Focus:Boolean read FFocus write SetFocus default False;
property FocusColor:TColor read FFocusColor write SetFocusColor default clHighlight;
property FocusWidth:TWidth read FFocusWidth write SetFocusWidth default 2;
property Font;
property Height default 25;
property Locked:Boolean read FLocked write FLocked default False;
property ParentColor default False;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property State:TRichButtonState read FState Write SetState default stUp;
property TabOrder;
property TabStop;
property Visible;
property Width default 75;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize: TNotifyEvent read FOnResize write FOnResize;
property OnStartDrag;
property Lines:TStrings read GetLines write SetLines; {properties stored in TRichEdit}
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Additional', [TRichButton]);
end;
constructor TRichButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csAcceptsControls, csCaptureMouse, csOpaque, csDoubleClicks, csReplicatable];
RichEdit:=TRichEdit.Create(Self); {create the RTF control}
RichEdit.Parent:=Self; {set the TRichButton as the parent}
FDefAttributes:=RichEdit.DefAttributes; {use the DefAttributes of the RichEdit}
FSelAttributes:=RichEdit.SelAttributes; {use the SelAttributes of the RichEdit}
FParagraph:=RichEdit.Paragraph; {use the Paragraph of the RichEdit}
Width:=75;
Height:=25;
FAlignment := taCenter;
FAllowDown:=False;
BevelOuter := bvRaised;
BevelWidth:=2;
FBorderStyle := bsNone;
Color:=clBtnFace;
FFocus:=False;
FFocusColor:=clHighlight;
FFocusWidth:=2;
FFullRepaint := True;
ParentColor:=False;
FState:=stUp;
MouseCaught:=False;
HasFocus:=False;
end;
procedure TRichButton.CreateParams(var Params: TCreateParams);
const
BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER);
begin
inherited CreateParams(Params);
with Params do
begin
Style := Style or BorderStyles[FBorderStyle];
if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
begin
Style := Style and not WS_BORDER;
ExStyle := ExStyle or WS_EX_CLIENTEDGE;
end;
end;
end;
procedure TRichButton.CreateWnd;
begin
inherited CreateWnd; {call the inherited CreatWnd() procedure}
RichEdit.BorderStyle:=bsNone; {don't show a border on the RTF control}
RichEdit.Enabled:=False; {disable the RTF control altogether, to get rid of the cursor}
RichEdit.ReadOnly:=True; {don't allow the rich text to be changed}
RichEdit.TabStop:=False; {don't allow the rich text to tabbed to}
RichEdit.ParentColor:=False; {don't use the parent color}
RichEdit.ParentCtl3D:=False; {don't use the parent's Ctl3D style}
RichEdit.ParentFont:=False; {don't use the parent font}
RichEdit.Font:=Font; {set the RichEdit to the same font as the button}
RichEdit.Color:=Color; {set the RichEdit to the same color as the button}
if csDesigning in ComponentState then {if we are designing the component}
begin
RichEdit.Paragraph.Alignment:=taCenter; {center the text}
RichEdit.Lines.Add(Name); {show the name of the control}
end;
end;
procedure TRichButton.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;
procedure TRichButton.CMColorChanged(var Message: TMessage);
begin
inherited;
if Parent<>Nil then {if we have a parent (for some reason, we must have this or an error will occur upon creation)}
RichEdit.Color:=Color; {set the RichEdit to the same color}
end;
procedure TRichButton.CMFontChanged(var Message: TMessage);
begin
inherited;
RichEdit.Font:=Font; {set the RichEdit to the same font}
end;
procedure TRichButton.CMCtl3DChanged(var Message: TMessage);
begin
if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
inherited;
end;
procedure TRichButton.CMIsToolControl(var Message: TMessage);
begin
if not FLocked then Message.Result := 1;
end;
procedure TRichButton.Resize;
begin
RichEdit.BoundsRect:=GetWorkRect; {change the size of the RTF control}
if FullRepaint then Invalidate;
if Assigned(FOnResize) then FOnResize(Self);
end;
procedure TRichButton.WMSize(var Message: TWMSize);
begin
inherited;
if not (csLoading in ComponentState) then Resize;
end;
procedure TRichButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); {modified from TTransBitmap}
var
rect:TRect;
overControl:Boolean;
begin
inherited MouseDown(Button, Shift, X, Y); {call the inherited MouseDown() procedure}
rect:=GetWorkRect; {find the working area of the button}
overControl:=(X>=rect.Left) and (x<=rect.Right) and (y>=rect.Top) and (y<=rect.Bottom); {see if the mouse is inside the pressable part of the button}
if (overControl) and (Button=mbLeft) and (FState<>stDisabled) then {if this was the left mouse button, and the button isn't disabled}
begin
MouseCaught:=True; {show that the left mouse button has been pressed down on the button}
OrigState:=FState; {keep track of the original state of the button, in case we allow it to stay down}
if FState<>stDown then {if the button isn't down already, put it down}
begin
FState:=stDown; {put the button down}
Realign; {realign the controls in the button}
Invalidate; {invalidate the button for repainting}
end;
end;
end;
procedure TRichButton.MouseMove(Shift: TShiftState; X, Y: Integer); {modified from TTransBitmap}
var
newState:TRichButtonState;
needRepaint:Boolean;
newHasFocus:Boolean;
rect:TRect;
begin
inherited MouseMove(Shift, X, Y); {call the inherited MouseMove() procedure}
needRepaint:=False; {assume we don't need to repaint the button}
rect:=GetWorkRect; {find the working area of the button}
newHasFocus:=(X>=rect.Left) and (x<=rect.Right) and (y>=rect.Top) and (y<=rect.Bottom); {see if the mouse is still inside the button}
if HasFocus<>newHasFocus then {if we have went to a different focus state by the mouse movement}
begin
HasFocus:=newHasFocus; {show our new focus state}
needRepaint:=FFocus; {if should accept show focus, we should repaint}
end;
if MouseCaught then {if the mouse was originally clicked on the button}
begin
if not FAllowDown or (OrigState<>stDown) then {if we don't allow the button to be down (or it isn't down, anyway)}
begin
if HasFocus then {update the state of the button, based on whether the mouse is inside the button or not}
newState:=stDown {if the mouse is inside, put the button down}
else {if the mouse is outside}
newState:=stUp; {bring the button up}
if newState<>FState then {if the state has changed}
begin
FState:=newState; {change the state permanently}
needRepaint:=True; {show that we should repaint the button}
end;
end;
end
else {if the mouse is just moving over the control, and wasn't originally click in the control}
MouseCapture:=FFocus and HasFocus; {if we should show focus, and we have the focus, send messages to the control so we'll know when we lose focus}
if needRepaint then {if we need to repaint}
begin
Realign; {realign the controls in the button}
Invalidate; {invalidate the button for repainting}
end;
end;
procedure TRichButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); {modified from TTransBitmap}
var
overControl:Boolean;
rect:TRect;
begin
inherited MouseUp(Button, Shift, X, Y); {call the inherited MouseUp() procedure}
if MouseCaught then {if the mouse was originally clicked over the control}
begin
MouseCaught:=False; {show that the mouse is no longer caught}
rect:=GetWorkRect; {find the working area of the button}
overControl:=(X>=rect.Left) and (x<=rect.Right) and (y>=rect.Top) and (y<=rect.Bottom); {see if the mouse is still inside the button}
if FAllowDown and overControl then {if we should allow the button to stay down, and the mouse button was released over the control}
begin
if OrigState=stDown then FState:=stUp else FState:=stDown; {set the new state to the opposite of what it was originally}
end
else {if this is a typical "non-stay-down" button}
FState:=stUp; {the button goes up after the mouse is released}
HasFocus:=False; {show that we no longer have the focus}
Realign; {realign the controls in the button}
Invalidate; {invalidate the button for repainting}
if overControl then Click; {if they released the mouse button over the control, call the OnClick() event}
end;
end;
function TRichButton.GetWorkRect:TRect; {modified from TTransBitmap}
var
delta:Integer; {number of units to remove from left, right, top, and bottom to get the work rectangle}
begin
delta:=FBorderWidth; {always start with the border width}
if FFocus then {if we show the focus when the mouse moves over the button}
Inc(delta, FFocusWidth); {allow for the focus rectangle}
if FBevelOuter<>bvNone then {if we have an outer bevel}
Inc(delta, FBevelWidth); {take the outer bevel away from our work rectangle}
if FBevelInner<>bvNone then {if we have an inner bevel}
Inc(delta, FBevelWidth); {take the inner bevel away from our work rectangle}
Result:=GetClientRect; {get the coordinates of the control}
InflateRect(Result, -delta, -delta); {remove the non-work areas from our work rectangle}
end;
procedure TRichButton.AlignControls(AControl: TControl; var Rect: TRect);
var
BevelSize: Integer;
begin
BevelSize := BorderWidth;
if BevelOuter <> bvNone then Inc(BevelSize, BevelWidth);
if BevelInner <> bvNone then Inc(BevelSize, BevelWidth);
InflateRect(Rect, -BevelSize, -BevelSize);
inherited AlignControls(AControl, Rect);
end;
procedure TRichButton.ReadData(Reader: TReader);
begin
ShowHint := Reader.ReadBoolean;
end;
procedure TRichButton.Paint;
var
Rect, WorkRect:TRect;
TopColor, BottomColor: TColor;
FontHeight: Integer;
procedure AdjustColors(Bevel: TPanelBevel); {routine supplied by Borland, optimized in TTransBitmap, further optimized in TRichButton}
begin
if (Bevel=bvLowered) or (FState=stDown) then {if the bevel is lowered and the button is up}
begin
TopColor:=clBtnShadow; {show the top and bottom colors normally}
BottomColor:=clBtnHighlight;
end
else {if the bevel is not lowered}
begin
TopColor:=clBtnHighlight; {switch the top and bottom colors}
BottomColor:=clBtnShadow;
end;
end;
begin
Rect:=GetClientRect; {get the rectangle that outlines the control}
WorkRect:=GetWorkRect; {get the working area}
if FState=stDown then {if the button is down}
begin
OffsetRect(WorkRect, 2, 1); //move the text down and to the right to similate a click
InflateRect(WorkRect, -2, -1); //
end;
RichEdit.BoundsRect:=WorkRect; {make sure the RTF control is positioned correctly}
RichEdit.Refresh; {make sure that the RTF control is updated (we only need this if the button has been hidden; there should be a way to make this more efficient)}
RichEdit.Invalidate; {make sure that the RTF control is updated (we only need this if the button has been hidden; there should be a way to make this more efficient)}
RichEdit.Update; {we need to call both Invalidate and Update; Refresh apparently does *not* do this inside the Paint procedure}
if FFocus then {if we should show the focus when the mouse is over the control}
begin
if HasFocus then {if we do actually have the focus}
Frame3D(Canvas, Rect, FFocusColor, FFocusColor, FFocusWidth) {show the focus}
else {if the mouse isn't over the button}
Frame3D(Canvas, Rect, clBtnFace, clBtnFace, FFocusWidth); {show the focus outline normally}
end;
if BevelOuter<>bvNone then {if we have an outer bevel}
begin
AdjustColors(BevelOuter); {determine the colors to use for the outer bevel}
Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); {draw the outer bevel}
end;
Frame3D(Canvas, Rect, Color, Color, BorderWidth); {draw the border}
if BevelInner<>bvNone then {if we have an inner bevel}
begin
AdjustColors(BevelInner); {determine the colors to use for the outer bevel}
Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); {draw the inner bevel}
end;
end;
procedure TRichButton.SetAlignment(Value: TAlignment);
begin
FAlignment := Value;
Invalidate;
end;
procedure TRichButton.SetAllowDown(Value:Boolean); {modified from TTransBitmap}
begin
if FallowDown<>Value then {if the value is really being changed}
begin
FAllowDown:=Value; {update the variable}
if (not FAllowDown) and (FState=stDown) then {if we shouldn't allow the button to be down, but it is}
begin
FState:=stUp; {bring the button up}
Realign; {realign the controls in the button}
Invalidate; {invalidate the button for repainting}
end;
end;
end;
procedure TRichButton.SetBevelInner(Value: TPanelBevel);
begin
FBevelInner := Value;
Realign;
Invalidate;
end;
procedure TRichButton.SetBevelOuter(Value: TPanelBevel);
begin
FBevelOuter := Value;
Realign;
Invalidate;
end;
procedure TRichButton.SetBevelWidth(Value: TBevelWidth);
begin
FBevelWidth := Value;
Realign;
Invalidate;
end;
procedure TRichButton.SetBorderWidth(Value: TBorderWidth);
begin
FBorderWidth := Value;
Realign;
Invalidate;
end;
procedure TRichButton.SetBorderStyle(Value: TBorderStyle);
begin
if FBorderStyle <> Value then
begin
FBorderStyle := Value;
RecreateWnd;
end;
end;
procedure TRichButton.SetFocus(Value:Boolean); {modified from TTransBitmap}
begin
if FFocus<>Value then {if the value is really being changed}
begin
FFocus:=Value; {set the new value}
Realign; {realign the controls in the button}
Invalidate; {invalidate the button for repainting}
end;
end;
procedure TRichButton.SetFocusColor(Value:TColor); {modified from TTransBitmap}
begin
if FFocusColor<>Value then {if the value is really being changed}
begin
FFocusColor:=Value; {change the value}
Invalidate; {invalidate the button for repainting}
end;
end;
procedure TRichButton.SetFocusWidth(Value:TWidth); {modified from TTransBitmap}
begin
if FFocusWidth<>Value then {if the value is really being changed}
begin
FFocusWidth:=Value; {change the value}
Realign; {realign the controls in the button}
Invalidate; {invalidate the button for repainting}
end;
end;
function TRichButton.GetLines:TStrings;
begin
Result:=RichEdit.Lines; {get the richedit's lines}
end;
procedure TRichButton.SetLines(Value:TStrings);
begin
RichEdit.Lines:=Value; {set the richedit's lines}
end;
procedure TRichButton.SetState(Value:TRichButtonState); {modified from TTransBitmap}
begin
if FState<>Value then {if the value is really being changed}
begin
if (Value=stDown) and (not FAllowDown) then {if they want the button down, but we don't allow it}
begin
if FState=stUp then {if the button is up, disable it, otherwise, bring it up}
FState:=stDisabled
else
FState:=stUp;
end
else {if they want to bring the button up, or they want to put it down and we allow it (or they want to disable it)}
FState:=Value; {actually change the state of the button}
Realign; {realign the controls in the button}
Invalidate; {invalidate the button for repainting}
end;
end;
end.