Solved

Make more perfect

Posted on 1998-10-13
5
316 Views
Last Modified: 2010-04-03
How to make this component looks like TButton.
In TButton after OnClick event, it will go up without wait a process completed.
To see the difference try to put this component in form1 (as a procedure) and call form2 (form2.showmodal).
This component looked "down" and after close form2, it will be back go up.

unit TButton;

interface

uses
  Windows, Messages, Classes, Graphics, Controls, ExtCtrls;

type
  TButtonState=(bsUp,bsDown);
  TAlignment=(taLeft,taCenter,taRight);

type
  TTButton = class(TGraphicControl)
  private
    FAlignment:        TAlignment;
    FCaption:          TCaption;
    FTransparent:      Boolean;
    FWordWrap:         Boolean;
    FMouseDown:        Boolean;
    FMouseInside:      Boolean;
    FState:            TButtonState;
    FInsideButton:     Boolean;

    procedure SetAlignment(Value:TAlignment);
    procedure SetCaption(Value:TCaption);
    procedure SetTransparent(Value:boolean);
    procedure SetWordWrap(Value:boolean);
  protected
    procedure DrawTheText;
    function  InsideBtn(X,Y: Integer): boolean;
    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 Paint;  override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Click; override;
  published
    property Alignment:TAlignment read FAlignment write SetAlignment default taCenter;
    property Caption: TCaption read FCaption write SetCaption;
    property Enabled;
    property Font;
    property ShowHint;
    property Transparent: boolean read FTransparent write SetTransparent default True;
    property Visible;
    property WordWrap:boolean read FWordWrap write SetWordWrap default False;

    property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

constructor TTButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csOpaque];
  FState := bsUp;
  FMouseInside := False;
  SetBounds(0,0,60,30);
  FAlignment := taCenter;
  FTransparent := True;
  FMouseDown:= False;
  FInsideButton := False;
  FWordwrap := False;
end;

procedure TTButton.SetAlignment(Value:TAlignment);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    Invalidate;
  end;
end;

procedure TTButton.SetCaption(Value: TCaption);
begin
  if FCaption <> Value then
  begin
    FCaption := Value;
    Invalidate;
  end;
end;

procedure TTButton.SetTransparent(Value:boolean);
begin
  if FTransparent <> Value then
  begin
    if Value then
      ControlStyle := ControlStyle - [csOpaque]
    else
      ControlStyle := ControlStyle + [csOpaque];
    FTransparent := Value;
    Invalidate;
  end;
end;

procedure TTButton.SetWordWrap(Value:boolean);
begin
  if FWordWrap <> Value then
  begin
    FWordwrap := Value;
    Invalidate;
  end;
end;

function TTButton.InsideBtn(X,Y: Integer): boolean;
begin
  Result := PtInRect(Rect(0,0,Width,Height),Point(X,Y));
end;

procedure TTButton.Paint;
var
  TmpRect:TRect;

begin
  TmpRect := Rect(0,0,Width,Height);

  with Canvas do
  begin
    Brush.Color := clBtnFace;
    Pen.Color := clBlack;
    Pen.Width := 1;

    Pen.Color := clBlack;
    if not Transparent then
      Rectangle(1,1,Width,Height)
    else
    begin
      TmpRect := Rect(1,1,Width,Height);
      Frame3D(Canvas,TmpRect,clBlack,clBlack,1);
    end;

    TmpRect := Rect(1,1,Width-1,Height-1);

    if (FState = bsDown) then
    begin
      InflateRect(TmpRect,1,1);
      Frame3D(Canvas,TmpRect,clBlack,clBtnHighLight,1);
      Frame3D(Canvas,TmpRect,clBtnShadow,clBtnFace,1);
    end;

    if (FState = bsUp) then
    begin
      TmpRect := Rect(1,1,Width-1,Height-1);

      InflateRect(TmpRect,1,1);
      Frame3D(Canvas,TmpRect,clBtnHighLight,clBlack,1);
      Frame3D(Canvas,TmpRect,clBtnFace,clBtnShadow,1);
    end;
  end;

  DrawTheText;
end;

procedure TTButton.DrawTheText;
var
  Flags,MidX,MidY: Integer;
  DC: THandle;
  Tmprect: TRect;

begin
  Canvas.Font := Self.Font;
  DC := Canvas.Handle;

  if FWordWrap then
    Flags := DT_WORDBREAK
  else
    Flags := DT_SINGLELINE;

  TmpRect := Rect(0,0,Width,Height);

  DrawText(DC, PChar(FCaption), Length(FCaption), TmpRect, Flags or DT_CALCRECT);
  MidY := TmpRect.Bottom - TmpRect.Top;
  MidX := TmpRect.Right  - TmpRect.Left;
  Flags := DT_CENTER;

  case Alignment of
    taLeft:
      OffsetRect(TmpRect,0,Height div 2 - MidY div 2);
    taCenter:
      OffsetRect(TmpRect,Width div 2 - MidX div 2,Height div 2 - MidY div 2);
    taRight:
      OffsetRect(TmpRect,Width  - MidX,Height div 2 - MidY div 2);
  end;

  if FWordWrap then
    Flags := Flags or DT_WORDBREAK or DT_NOCLIP
  else
    Flags := Flags or DT_SINGLELINE or DT_NOCLIP;

  if FState = bsDown then
      OffsetRect(TmpRect,1,1);

  SetBkMode(DC,Windows.TRANSPARENT);

  if not Enabled then
  begin
    SetTextColor(DC,ColorToRGB(clBtnHighLight));
    OffsetRect(tmpRect,1,1);
    DrawText(DC, PChar(FCaption), Length(FCaption), TmpRect, Flags);
    OffsetRect(TmpRect,-1,-1);
    SetTextColor(DC,ColorToRGB(clBtnShadow));
  end
  else
    SetTextColor(DC,self.Font.Color);

  DrawText(DC, PChar(FCaption), Length(FCaption), TmpRect, Flags);
end;

procedure TTButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if not Enabled then Exit;
  inherited MouseDown(Button,Shift,X,Y);
  if Assigned(OnMouseDown) then OnMouseDown(Self,Button,Shift,X,Y);
  if InsideBtn(X,Y) then
  begin
    FMouseDown := True;
    FState := bsDown;
    Repaint;
  end;
end;

procedure TTButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if not Enabled then Exit;
  inherited MouseUp(Button,Shift,X,Y);
  FMouseDown := False;
  FState := bsUp;
  Repaint;
  if Assigned(OnMouseUp) then OnMouseUp(Self,Button,Shift,X,Y);
end;

procedure TTButton.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift,X,Y);
  if Assigned(OnMouseMove) then OnMouseMove(Self,Shift,X,Y);
  if FMouseDown then
  begin
    if not InsideBtn(X,Y) then
    begin
      if FState = bsDown then
      begin
        FState := bsUp;
        Repaint;
      end;
    end
    else
    begin
      if FState = bsUp then
      begin
        FState := bsDown;
        Repaint;
      end;
    end;
  end;
end;

procedure TTButton.Click;
begin
  inherited Click;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TTButton]);
end;

end.
0
Comment
Question by:joely
  • 3
  • 2
5 Comments
 
LVL 1

Expert Comment

by:BlackDeath
ID: 1342684
well, it seems that the problem is, that directly after pressing the mousebutton the onclick-proc is to be carried out and _afterwards_ the mouseup-proc takes place.

afaik, for tbutton (via twincontrol via tcontrol) this is handled by the messaging system and windows' standard styles... (?)

i don't think there's a proper way to make your code run as intended.

sorry, that wasn't much help.

bye,

Black Death.
0
 

Accepted Solution

by:
tleforge earned 50 total points
ID: 1342685
Simply declare 4 global variables
    Var
      glbButton: TMouseButton;
      glbShift: TShiftState;
      glbX, glbY: Integer;

In the MouseDown event type in the following at the very end:
    glbButton := Button;
    glbShift := Shift;
    glbX := X;
    glbY := Y;

In the Click event type in the following at the very TOP:
    MouseUp(glbButton, glbShift, glbX, glbY);

This should get you the desired effects.  Remember, however, that you are responsible for any code the developer may place in the MouseUp event, because it WILL get fired.



0
 
LVL 1

Expert Comment

by:BlackDeath
ID: 1342686
ja - that's the problem. described in your last sentence. i mean, this was obvious, waddaya think?...

;-)

Black Death.
0
 

Expert Comment

by:tleforge
ID: 1342687
Well... it's not really a problem.  That's actually how event-handling in a component is supposed to work...

. Oops! you were joking weren't you?  O.K. I'm a little slow on the uptake.  I mean, with a name like Black Death (and a cool name it is) I wasn't expecting a good sense of humor.  Sorry.

;-)
0
 
LVL 1

Expert Comment

by:BlackDeath
ID: 1342688
no prob, hellforge.

i'm quite a punch...
in fact, my humor's as black as my soul.
that makes me a little bit unwieldy in most people's opinion.
those people rather like my back than my front.
so those people never come to know me.
which is perfectly ok, cos those people are mostly the kind i really don't care of.
who cares anyway - those people dying young are longer dead...

>;->

that's enuff of that stuff.

have a nice day,

Black Death.



0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
delphi exception 7 68
SUM 2 INTEGER ARRAYS INTO 1 10 108
can i put an image from resource into image tag ? 6 27
Delphi: sending SMS on android platform 1 34
Objective: - This article will help user in how to convert their numeric value become words. How to use 1. You can copy this code in your Unit as function 2. than you can perform your function by type this code The Code   (CODE) The Im…
Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
With Secure Portal Encryption, the recipient is sent a link to their email address directing them to the email laundry delivery page. From there, the recipient will be required to enter a user name and password to enter the page. Once the recipient …
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

856 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question