Hi all,
I've been struggling a bit trying to get a custom component read for use in
Lazarus, but it seems my setbacks are fruitful. I have it working exactly as I
want it to under Delphi 2007.
Specifically the problems that I have are:
1. Siting the component at design time causes the mouse down and mouse up events
to not fire at runtime. Creating the component at runtime it works perfectly,
at least in respect to firing the mousedown and mouseup events.
2. I am trying to center text which I draw to the canvas in the OnPaint event
vertically. This works also very well in D2007, but does not seem to work
correctly in Lazarus, especially with larger fonts, which seem to push the rect
written to towards the top of the ClientRect.
I have attached the .pas file created for this component as I'm sure that is
something that I am missing in getting it to work correctly in lazarus, although
as I said before, its working perfectly under Delphi 2007.
Thanks you for your help.
p.s. I signed up for another account on the bug tracker about between 30 and 45
minutes ago. Is this usual to wait this long to get the confirmation email?
I've had many problems trying to get an account activated for some reason, not
certain why however. This last time, I opted to create a whole new profile. I
have checked and re-checked my junk mail filters and junk mail folder. I am
convinced it doesn't like me :)
--
Warm Regards,
Lee
unit pos_button;
{< Contains TPOSButton which is a custom drawn button inherited from
TShape as a simple button widget that displays the same in windows
or linux.}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
interface
uses
SysUtils
,Classes
,Windows
,Graphics
,Controls
,ExtCtrls
,StdCtrls
,Forms
,Messages
;
type
TPOSButtonState = (bsUp, bsDown);
// -----------------------------------------------------------------
// Class Objects
// -----------------------------------------------------------------
{ TDTPOSButton class }
TPOSButton = class(TShape)
private
FUpColor: TColor;
FOnButtonClick: TNotifyEvent;
FButtonPicture: TBitmap;
FButtonState: TPOSButtonState;
FDownBorderColor: TColor;
FCaption: string;
FButtonFont: TFont;
FUpBorderColor: TColor;
FDataString: string;
FDownColor: TColor;
FBorderWidth: Integer;
FData: TObject;
FDownFont: TFont;
FWidgetClass: string;
// private methods
procedure DoOnFontChanged(Sender: TObject);
function GetParentColor: TColor;
procedure DrawBorder;
procedure Resize;
procedure SetBorderWidth(const Value: Integer);
procedure SetButtonFont(const Value: TFont);
procedure SetButtonPicture(const Value: TBitmap);
procedure SetButtonState(const Value: TPOSButtonState);
procedure SetCaption(const Value: string);
procedure SetData(const Value: TObject);
procedure SetDataString(const Value: string);
procedure SetDownBorderColor(const Value: TColor);
procedure SetDownColor(const Value: TColor);
procedure SetDownFont(const Value: TFont);
procedure SetOnButtonClick(const Value: TNotifyEvent);
procedure SetUpBorderColor(const Value: TColor);
procedure SetUpColor(const Value: TColor);
procedure SetWidgetClass( const AValue: string) ;
protected
{ Determines if the passed in control is the same as a control at location
x & y. }
function IsSameControl(x, y: Integer): Boolean;
{ Handles mousedown event to change image.}
procedure HandleMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
{ Handles mouseup event to change image back. }
procedure HandleMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
{ Draw the Up state button and the caption. }
procedure DoDrawUpStateNew;
{ Draw the Down state button. }
procedure DoDrawDownStateNew;
procedure DoDrawButton;
procedure Paint; override;
published
// ---> Properties
property Caption: string read FCaption write SetCaption;
property ButtonFont: TFont read FButtonFont write SetButtonFont;
property ButtonPicture: TBitmap read FButtonPicture write
SetButtonPicture;
property OnButtonClick: TNotifyEvent read FOnButtonClick write
SetOnButtonClick;
property UpColor: TColor read FUpColor write SetUpColor;
property UpBorderColor: TColor read FUpBorderColor write
SetUpBorderColor;
property DownColor: TColor read FDownColor write SetDownColor;
property DownBorderColor: TColor read FDownBorderColor write
SetDownBorderColor;
property DownFont: TFont read FDownFont write SetDownFont;
property WidgetClass: string read FWidgetClass write SetWidgetClass;
public
// ---> Construction Ahead
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// ---> Properties
property Data: TObject read FData write SetData;
property DataString: string read FDataString write SetDataString;
property ButtonState: TPOSButtonState read FButtonState write
SetButtonState;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('DataTrak', [TPOSButton]);
end;
{ TDTPOSButton }
constructor TPOSButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FButtonState := bsUp;
// reduce flicker?
ControlStyle := ControlStyle + [csOpaque];
// create font objects to use.
FButtonFont := TFont.Create;
FDownFont := TFont.Create;
//{$IFDEF FPC}
//FButtonFont.OnChange := @DoOnFontchanged;
//{$ELSE}
FButtonFont.OnChange := DoOnFontchanged;
//{$ENDIF}
//{$IFDEF fpc}
//Self.OnMouseDown := @HandleMouseDown;
//self.OnMouseUp := @HandleMouseUp;
//{$ELSE}
Self.OnMouseDown := HandleMouseDown;
self.OnMouseUp := HandleMouseUp;
// FLabel.OnMouseDown := HandleMouseDown;
// FLabel.OnMouseUp := HandleMouseUp;
//{$ENDIF}
end;
destructor TPOSButton.Destroy;
begin
FButtonFont.Free;
FDownFont.Free;
inherited;
end;
procedure TPOSButton.DoDrawButton;
begin
if FButtonState = bsUp then
DoDrawUpStateNew
else
DoDrawDownStateNew;
end;
procedure TPOSButton.DoDrawDownStateNew;
var
lRect, lTempRect: TRect;
lFlags: Integer;
begin
// setup rect
lRect.Left := 5;
lRect.Top := 0;
lRect.Right := Width -5;
lRect.Bottom := Height;
DrawBorder;
Canvas.Font.Assign(FDownFont);
Canvas.Brush.Style := bsClear;
lFlags := DT_WORDBREAK or DT_CENTER;
lTempRect := ClientRect;
{$IFDEF FPC}
DrawText(Canvas.Handle, PChar(AnsiToUtf8(FCaption)), Length(FCaption),
lTempRect, lFlags or DT_CALCRECT);
lRect.Top := (Height div 2) - lTempRect.Bottom ;
DrawText(Canvas.Handle, PChar(AnsiToUtf8(FCaption)), -1, lRect, lFlags);
{$ELSE}
DrawText(Canvas.Handle, PChar(FCaption), Length(FCaption), lTempRect,
lFlags or DT_CALCRECT);
lRect.Top := (Height div 2) - lTempRect.Bottom;
DrawText(Canvas.Handle, PChar(FCaption), -1, lRect, lFlags);
{$ENDIF}
end;
procedure TPOSButton.DoDrawUpStateNew;
var
lRect, lTempRect: TRect;
lFlags: integer;
begin
// setup rect
lRect.Left := 5;
lRect.Top := 0;
lRect.Right := Width -5 ;
lRect.Bottom := Height ;
DrawBorder;
Canvas.Font.Assign(FButtonFont);
Canvas.Brush.Style := bsClear;
lFlags := DT_WORDBREAK or DT_CENTER;
lTempRect := ClientRect;
{$IFDEF FPC}
DrawText(Canvas.Handle, PChar(AnsiToUtf8(FCaption)), Length(FCaption),
lTempRect, lFlags or DT_CALCRECT);
lRect.Top := (Height div 2) - lTempRect.Bottom;
DrawText(Canvas.Handle, PChar(AnsiToUtf8(FCaption)), -1, lRect, lFlags);
{$ELSE}
DrawText(Canvas.Handle, PChar(FCaption), Length(FCaption), lTempRect,
lFlags or DT_CALCRECT);
lRect.Top := (Height div 2) - lTempRect.Bottom;
DrawText(Canvas.Handle, PChar(FCaption), -1, lRect, lFlags);
{$ENDIF}
end;
procedure TPOSButton.DoOnFontChanged(Sender: TObject);
begin
//FLabel.Font.Assign(FButtonFont);
//DoDrawButton;
Invalidate;
end;
procedure TPOSButton.DrawBorder;
begin
if FButtonState = bsUp then
begin
Pen.Color := FUpBorderColor;
Brush.Color := FUpColor;
end
else
begin
Pen.Color := FDownBorderColor;
Brush.Color := FDownColor;
end;
end;
function TPOSButton.GetParentColor: TColor;
begin
if Parent is TPanel then
result := TPanel(Parent).Color
else if Parent is TForm then
result := TForm(Parent).Color
{$ifdef fpc}
;
{$else}
else if parent is TFlowPanel then
result := TFlowPanel(Parent).Color;
{$endif}
end;
procedure TPOSButton.HandleMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
FButtonState := bsDown;
DoDrawDownStateNew;
end;
end;
procedure TPOSButton.HandleMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
FButtonState := bsUp;
DoDrawUpStateNew;
if IsSameControl(x, y) then
if Assigned(FOnButtonClick) then
FOnButtonClick(Self);
end;
end;
function TPOSButton.IsSameControl(x, y: Integer): Boolean;
var
lControl: TControl;
lPoint: TPoint;
begin
// Check to see if control a location x,y is self.
lPoint.X := x;
lPoint.Y := y;
{$IFDEF FPC}
// Note: Does not seem to work un FPC/Lazarus
lControl := Parent.ControlAtPos(lPoint, [capfAllowDisabled,
capfAllowWinControls]);
{$ELSE}
lControl := Parent.ControlAtPos(lPoint, True, True, false);
{$ENDIF}
result := (lControl = Self);
end;
procedure TPOSButton.Paint;
begin
inherited Paint;
DoDrawButton;
end;
procedure TPOSButton.Resize;
begin
inherited;
//DoDrawButton;
//Invalidate;
end;
procedure TPOSButton.SetBorderWidth(const Value: Integer);
begin
FBorderWidth := Value;
end;
procedure TPOSButton.SetButtonFont(const Value: TFont);
begin
FButtonFont := Value;
//DoDrawButton;
Invalidate;
end;
procedure TPOSButton.SetButtonPicture(const Value: TBitmap);
begin
FButtonPicture := Value;
end;
procedure TPOSButton.SetButtonState(const Value: TPOSButtonState);
begin
FButtonState := Value;
end;
procedure TPOSButton.SetCaption(const Value: string);
begin
{$IFDEF FPC}
FCaption := AnsiToUtf8(Value);
{$ELSE}
FCaption := Value;
{$ENDIF}
//DoDrawButton;
//Invalidate;
end;
procedure TPOSButton.SetData(const Value: TObject);
begin
FData := Value;
end;
procedure TPOSButton.SetDataString(const Value: string);
begin
FDataString := Value;
end;
procedure TPOSButton.SetDownBorderColor(const Value: TColor);
begin
FDownBorderColor := Value;
// DoDrawButton;
Invalidate;
end;
procedure TPOSButton.SetDownColor(const Value: TColor);
begin
FDownColor := Value;
//DoDrawButton;
Invalidate;
end;
procedure TPOSButton.SetDownFont(const Value: TFont);
begin
FDownFont := Value;
//DoDrawButton;
Invalidate;
end;
procedure TPOSButton.SetOnButtonClick(const Value: TNotifyEvent);
begin
FOnButtonClick := Value;
end;
procedure TPOSButton.SetUpBorderColor(const Value: TColor);
begin
FUpBorderColor := Value;
//DoDrawButton;
Invalidate;
end;
procedure TPOSButton.SetUpColor(const Value: TColor);
begin
FUpColor := Value;
//DoDrawButton;
Invalidate;
end;
procedure TPOSButton.SetWidgetClass( const AValue: string) ;
begin
if FWidgetClass= AValue then exit;
FWidgetClass:= AValue;
end;
end.
_______________________________________________
Lazarus mailing list
[email protected]
http://www.lazarus.freepascal.org/mailman/listinfo/lazarus
