Chip 2001 December/Chip_2001-12_cd1.bin/zkuste/delphi/kolekce/d345/JWTOOL.ZIP/jwtool/JwFshCl.pas

Pascal/Delphi Source File | 2001-09-29 | 10.8 KB | 396 lines

unit JwFshCl;

{
        **   VERSION History   **
   Version     Date     Notes
    v1.00  - 01APR99    Original Release
}

{
     Three stage buttons:
           The idea is that you want one "look" in an "unfocused" state, another
     when you are in a "mouseover" state, and a third when you are clicking.  This
     idea is taken in the FlashClick, FlashPanel, and PopButton.

          The FlashClick shares a lot of code with the flash panel.  The difference is
     that the FlashClick is inherited from a TLabel, and therefore does not have a
     canvas of it's own, which can save on memory.  Since there isn't a default MouseExit
     and MouseEnter events (I got use to those programming in XWindows...) I had to make
     my own.  But in essence, you now have a lowmemory Web-like button.

}

//  Created By:
//    Joseph Wilcock
//    [e-mail]
//    http://msnhomepages.talkcity.com/RedmondAve/coockoo/


interface

uses {$IFDEF WIN32} Windows, {$ELSE} WinProcs, WinTypes, {$ENDIF} Messages,
     SysUtils, Classes, Controls, Forms, Graphics, Stdctrls;

type
{Windows Messaging is rather nasty.  Since I want to add user-defined methods to
something that delphi hasn't already defined, namely OnMouseExit and OnMouseEnter,
I will have to do it myself.  First, I need to redefine the message record.  In
this case I literally took it from the TWMMouse message, repeated twice under two
names.  (I Might want to change that later).}

  TWMMouseExit = record
    Msg: Cardinal;
    Keys: Longint;
    case Integer of
      0: (
        XPos: Smallint;
        YPos: Smallint);
      1: (
        Pos: TSmallPoint;
        Result: Longint);
  end;

  TWMMouseEnter = record
    Msg: Cardinal;
    Keys: Longint;
    case Integer of
      0: (
        XPos: Smallint;
        YPos: Smallint);
      1: (
        Pos: TSmallPoint;
        Result: Longint);
  end;


  {The next thing to do is define a new custom "TNotify" event.  Once again,
  even though I am repeating myself, I'm going to use the same thing twice
  just in case I want to change things.}
  TMouseExit = procedure(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer) of object;
  TMouseEnter = procedure(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer) of object;

  TJwFlashClick = class( TLabel )
    private
      { Private fields of TJwFlashClick }

        {The TNotifyEvent objects to use on the specific events}
        FOnEnter: TMouseEnter;
        FOnExit: TMouseExit;

      { Private methods of TJwFlashClick }
        procedure WMSize(var Message: TWMSize); message WM_SIZE;
        procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
        procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;

        {FINALLY.. we have a 3-stage event.  The CMMouseEnter and CMMouseLeave are the functions
        that actually look for the CM_MOUSEENTER and CM_MOUSELEAVE in the WinMain command loop.
        Once it hits, it will call the corresponding "Do" method which will call the "Mouse..."
        and that will call the TNotfy event if it is assigned.}
        procedure CMMouseEnter({var msg: TMessage}var Message: TWMMouseEnter); message CM_MOUSEENTER;
        procedure CMMouseLeave({var msg: TMessage}var Message: TWMMouseExit); message CM_MOUSELEAVE;
        procedure MouseEnter(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
        procedure DoMouseEnter(var Message: TWMMouseEnter; Button: TMouseButton;
                    Shift: TShiftState);
        procedure DoMouseExit(var Message: TWMMouseExit; Button: TMouseButton;
                    Shift: TShiftState);
        procedure MouseExit(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

        Procedure SetFlareFont( Value: TFont );
        Procedure SetBaseFont( Value: TFont );
        Procedure SetClickFont( Value: TFont );
        Procedure SetCommonFont( Value: TFont );
        Procedure SetCheckedValue( Value: Boolean );
        Function GetCheckValue: Boolean;
    protected
      { Protected fields of TJwFlashClick }
        FFlareMode: Byte;
        FBaseFont: TFont;
        FFlareFont: TFont;
        FClickFont: TFont;

        FCheckEffect: Boolean;
      { Protected methods of TJwFlashClick }
        procedure Click; override;
        procedure Loaded; override;
        procedure Paint; override;

    public
      { Public fields and properties of TJwFlashClick }

      { Public methods of TJwFlashClick }
        constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;

    published
      { Published properties of TJwFlashClick }
        Property Anchors;
        Property BaseFont: TFont Read FBaseFont Write SetBaseFont;
        Property FlareFont: TFont Read FFlareFont Write SetFlareFont;
        Property ClickFont: TFont Read FClickFont Write SetClickFont;
        Property CommonFont: TFont Read FBaseFont Write SetCommonFont;

        Property CheckEffect: Boolean Read FCheckEffect Write FCheckEffect;

        Property OnEnter: TMouseEnter Read FOnEnter Write FOnEnter;
        Property OnExit: TMouseExit Read FOnExit Write FOnExit;

        property OnClick;
        property OnDblClick;
        property OnDragDrop;
        property OnMouseDown;
        property OnMouseMove;
        property OnMouseUp;
  end;

procedure Register;

implementation

procedure Register;
begin
     { Register TJwFlashClick with Standard as its
       default page on the Delphi component palette }
     RegisterComponents('JwTools', [TJwFlashClick]);
end;

Procedure TJwFlashClick.SetCheckedValue( Value: Boolean );
begin
  if ( FCheckEffect ) then
    begin
      if Value then
        FFlareMode := 3
      else
        FFlareMode := 0;
      InValidate;
    end;
end;

Function TJwFlashClick.GetCheckValue: Boolean;
begin
  Result := ( FFlareMode = 3 );
end;

Procedure TJwFlashClick.SetCommonFont( Value: TFont );
begin
  {if Value <> FClickFont then
    begin}
      FClickFont.Assign( Value );
      FBaseFont.Assign( Value );
      FFlareFont.Assign( Value );
      Invalidate;
    {end;}
end;

Procedure TJwFlashClick.SetClickFont( Value: TFont );
begin
  {if Value <> FClickFont then
    begin}
      FClickFont.Assign( Value );
      Invalidate;
    {end;}
end;

Procedure TJwFlashClick.SetBaseFont( Value: TFont );
begin
  {if Value <> FBaseFont then
    begin}
      FBaseFont.Assign( Value );
      Invalidate;
    {end;}
end;

Procedure TJwFlashClick.SetFlareFont( Value: TFont );
begin
  {if Value <> FFlareFont then
    begin}
      FFlareFont.Assign( Value );
      Invalidate;
    {end;}
end;


{ Override OnClick handler from TLabel }
procedure TJwFlashClick.Click;
begin
     { Code to execute before activating click
       behavior of component's parent class }

     { Activate click behavior of parent }
     inherited Click;

     { Code to execute after click behavior
       of parent }

end;


constructor TJwFlashClick.Create(AOwner: TComponent);
begin
  { Call the Create method of the parent class }
  inherited Create(AOwner);

  FBaseFont := TFont.Create;
  FFlareFont := TFont.Create;
  FClickFont := TFont.Create;

  FFlareMode := 0;
  FBaseFont.Assign( Self.Font );
  FBaseFont.Color := clWhite;
  FFlareFont.Assign( Self.Font );
  FFlareFont.Size := FFlareFont.Size + 2;
  FFlareFont.Color := clYellow;
  FClickFont.Assign( Self.Font );
  FClickFont.Size := ClickFont.Size + 2;
  FClickFont.Color := clRed;

  FCheckEffect := False;
end;

destructor TJwFlashClick.Destroy;
begin
  FBaseFont.Free;
  FFlareFont.Free;
  FClickFont.Free;
  inherited Destroy;
end;

procedure TJwFlashClick.Loaded;
begin
     inherited Loaded;

     { Perform any component setup that depends on the property
       values having been set }

end;

procedure TJwFlashClick.Paint;
begin
     { Make this component look like its parent component by calling
       its parent's Paint method. }
     case FFlareMode of
       0: begin
            Self.Font := FBaseFont;
          end;
       1: begin
            Self.Font := FFlareFont;
          end;
     2,3: begin
            Self.Font := FClickFont;
          end;
     else
       Self.Font := FBaseFont;
     end;

     inherited Paint;
end;

procedure TJwFlashClick.WMSize(var Message: TWMSize);
var
     W, H: Integer;
begin
     inherited;

     W := Width;
     H := Height;

     if (W <> Width) or (H <> Height) then
        inherited SetBounds(Left, Top, W, H);

     Message.Result := 0;
end;

Procedure MsgToKey( Keys: Word; var MB: TMouseButton );
begin
  if Keys and MK_LBUTTON = MK_LBUTTON then
    MB := mbLeft
  else if Keys and MK_MBUTTON = MK_MBUTTON then
    MB := mbMiddle
  else if Keys and MK_RBUTTON = MK_RBUTTON then
    MB := mbRight;
end;

procedure TJwFlashClick.CMMouseEnter(var Message: TWMMouseEnter);
var
  MB: TMouseButton;
  SS: TShiftState;
begin
  if ( FFlareMode <> 3 ) then
    begin
      FFlareMode := 1;
      Invalidate;
    end;
  Inherited;
  // This information is processes twice.
  SS := Forms.KeysToShiftState( Message.Keys );
  MsgToKey( Message.Keys, MB );
  DoMouseEnter(Message, MB, SS);
end;

procedure TJwFlashClick.CMMouseLeave(var Message: TWMMouseExit);
var
  MB: TMouseButton;
  SS: TShiftState;
begin
  if ( FFlareMode <> 3 ) then
    begin
      FFlareMode := 0;
      Invalidate;
    end;
  Inherited;

  // This information is processes twice.
  SS := Forms.KeysToShiftState( Message.Keys );
  MsgToKey( Message.Keys, MB );
  DoMouseExit(Message, MB, SS);
end;

procedure TJwFlashClick.WMLButtonDown(var Message: TWMLButtonDown);
begin
  if ( FCheckEffect ) and ( FFlareMode <> 3 ) then
    FFlareMode := 3
  else
    FFlareMode := 2;
  Invalidate;
  Inherited;
end;

procedure TJwFlashClick.WMLButtonUp(var Message: TWMLButtonUp);
begin
  if ( FFlareMode <> 3 ) then
    begin
      FFlareMode := 1;
      Invalidate;
    end;
  Inherited;
end;

procedure TJwFlashClick.DoMouseEnter(var Message: TWMMouseEnter; Button: TMouseButton;
  Shift: TShiftState);
begin
  with Message do
    MouseEnter(Button, {KeysToShiftState(Keys) +} Shift, XPos, YPos);
end;

procedure TJwFlashClick.MouseEnter(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnEnter) then FOnEnter(Self, Button, Shift, X, Y);
end;

procedure TJwFlashClick.DoMouseExit(var Message: TWMMouseExit; Button: TMouseButton;
  Shift: TShiftState);
begin
  with Message do
    MouseExit(Button, {KeysToShiftState(Keys) +} Shift, XPos, YPos);
end;

procedure TJwFlashClick.MouseExit(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnExit) then FOnExit(Self, Button, Shift, X, Y);
end;

end.