Solved

Make more perfect

Posted on 1998-10-13
5
313 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

Master Your Team's Linux and Cloud Stack

Come see why top tech companies like Mailchimp and Media Temple use Linux Academy to build their employee training programs.

Question has a verified solution.

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

Suggested Solutions

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
Microsoft Active Directory, the widely used IT infrastructure, is known for its high risk of credential theft. The best way to test your Active Directory’s vulnerabilities to pass-the-ticket, pass-the-hash, privilege escalation, and malware attacks …
This video shows how to use Hyena, from SystemTools Software, to bulk import 100 user accounts from an external text file. View in 1080p for best video quality.

832 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