Solved

Make more perfect

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

Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

Join & Write a Comment

This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…
This tutorial demonstrates a quick way of adding group price to multiple Magento products.

744 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

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now