Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Make more perfect

Posted on 1998-10-13
5
Medium Priority
?
321 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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 200 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

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

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

Introduction The parallel port is a very commonly known port, it was widely used to connect a printer to the PC, if you look at the back of your computer, for those who don't have newer computers, there will be a port with 25 pins and a small print…
Hello everybody This Article will show you how to validate number with TEdit control, What's the TEdit control? TEdit is a standard Windows edit control on a form, it allows to user to write, read and copy/paste single line of text. Usua…
Sometimes it takes a new vantage point, apart from our everyday security practices, to truly see our Active Directory (AD) vulnerabilities. We get used to implementing the same techniques and checking the same areas for a breach. This pattern can re…
In this video, Percona Solutions Engineer Barrett Chambers discusses some of the basic syntax differences between MySQL and MongoDB. To learn more check out our webinar on MongoDB administration for MySQL DBA: https://www.percona.com/resources/we…
Suggested Courses

670 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