Tskinbutton : bouton présentant divers aspects selon son état

Soyez le premier à donner votre avis sur cette source.

Vue 3 990 fois - Téléchargée 368 fois

Description

ceci est mon premier composant, en voici la version corrigée

Source / Exemple :


unit SkinButtons;

interface

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

type
  TSkinButtonBorder = (sbFlat, sbNone);
  TSkinButtonStyle = (sbNormal, sbUpDown);
  TSkinButton = class(TGraphicControl)
  private
    IsDown: Boolean;
    IsHover: Boolean;
    FGlyphUpHover: TBitMap;
    FGlyphUpActive: TBitMap;
    FGlyphUpInactive: TBitMap;
    FGlyphDownHover: TBitMap;
    FGlyphDownActive: TBitMap;
    FGlyphDownInactive: TBitMap;
    FBorder: TSkinButtonBorder;
    FStyle: TSkinButtonStyle;
    FAutoSize: Boolean;
    FStretch: Boolean;
    FDown: Boolean;
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
  protected
    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
    procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;
    procedure MouseDown(Button: TmouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TmouseButton; Shift: TShiftState; X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetGlyphUpHover(Value: TBitMap);
    procedure SetGlyphUpActive(Value: TBitMap);
    procedure SetGlyphUpInactive(Value: TBitMap);
    procedure SetGlyphDownHover(Value: TBitMap);
    procedure SetGlyphDownActive(Value: TBitMap);
    procedure SetGlyphDownInactive(Value: TBitMap);
    procedure SetBorder(Value: TSkinButtonBorder);
    procedure SetStyle(Value: TSkinButtonStyle);
    procedure SetAutoSize(Value: Boolean); override;
    procedure SetStretch(Value: Boolean);
    procedure SetDown(Value: Boolean);
    procedure Click; override;
    procedure DblClick; override;
    procedure Paint; override;
    property Owner;
    property Parent;
  published
    property GlyphUpHover: TBitMap read FGlyphUpHover write SetGlyphUpHover;
    property GlyphUpActive: TBitMap read FGlyphUpActive write SetGlyphUpActive;
    property GlyphUpInactive: TBitMap read FGlyphUpInactive write SetGlyphUpInactive;
    property GlyphDownHover: TBitMap read FGlyphDownHover write SetGlyphDownHover;
    property GlyphDownActive: TBitMap read FGlyphDownActive write SetGlyphDownActive;
    property GlyphDownInactive: TBitMap read FGlyphDownInactive write SetGlyphDownInactive;
    property Border: TSkinButtonBorder read FBorder write SetBorder;
    property Style: TSkinButtonStyle read FStyle write SetStyle;
    property AutoSize: Boolean read FAutoSize write SetAutoSize;
    property Stretch: Boolean read FStretch write SetStretch;
    property Down: Boolean read FDown write SetDown;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property Align;
    property Anchors;
    property Caption;
    property Color;
    property Cursor;
    property Enabled;
    property Font;
    property Height;
    property Hint;
    property Left;
    property Name;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property Top;
    property Visible;
    property Width;
    property Tag;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

constructor TSkinButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  IsDown := false;
  IsHover := false;
  FGlyphUpHover := TBitMap.Create;
  FGlyphUpActive := TBitMap.Create;
  FGlyphUpInactive := TBitMap.Create;
  FGlyphDownHover := TBitMap.Create;
  FGlyphDownActive := TBitMap.Create;
  FGlyphDownInactive := TBitMap.Create;
  FBorder := sbFlat;
  FStyle := sbNormal;
  FAutoSize := false;
  FStretch := false;
  FDown := false;
  FOnMouseEnter := nil;
  FOnMouseLeave := nil;
  Height := 30;
  ParentColor := true;
  ParentFont := true;
  ParentShowHint := true;
  Width := 100;
end;

destructor TSkinButton.Destroy;
begin
  FGlyphUpHover.Free;
  FGlyphUpActive.Free;
  FGlyphUpInactive.Free;
  FGlyphDownHover.Free;
  FGlyphDownActive.Free;
  FGlyphDownInactive.Free;
  inherited Destroy;
end;

procedure TSkinButton.SetGlyphUpHover(Value: TBitMap);
begin
  FGlyphUpHover.Assign(Value);
  Invalidate;
end;

procedure TSkinButton.SetGlyphUpActive(Value: TBitMap);
begin
  FGlyphUpActive.Assign(Value);
  Invalidate;
end;

procedure TSkinButton.SetGlyphUpInactive(Value: TBitMap);
begin
  FGlyphUpInactive.Assign(Value);
  Invalidate;
end;

procedure TSkinButton.SetGlyphDownHover(Value: TBitMap);
begin
  FGlyphDownHover.Assign(Value);
  Invalidate;
end;

procedure TSkinButton.SetGlyphDownActive(Value: TBitMap);
begin
  FGlyphDownActive.Assign(Value);
  Invalidate;
end;

procedure TSkinButton.SetGlyphDownInactive(Value: TBitMap);
begin
  FGlyphDownInactive.Assign(Value);
  Invalidate;
end;

procedure TSkinButton.SetBorder(Value: TSkinButtonBorder);
begin
  FBorder := Value;
  Invalidate;
end;

procedure TSkinButton.SetStyle(Value: TSkinButtonStyle);
begin
  FStyle := Value;
  if FStyle = sbNormal
  then FDown := false;
  Invalidate;
end;

procedure TSkinButton.SetAutoSize(Value: Boolean);
begin
  FAutoSize := Value;
  Invalidate;
end;

procedure TSkinButton.SetStretch(Value: Boolean);
begin
  FStretch := Value;
  Invalidate;
end;

procedure TSkinButton.SetDown(Value: Boolean);
begin
  if FStyle = sbNormal
  then FDown := false
  else FDown := Value;
  Invalidate;
end;

procedure TSkinButton.CMMouseEnter(var Msg: TMessage);
begin
  if Enabled
  then begin
    IsHover := true;
    Invalidate;
    if Assigned(FOnMouseEnter)
    then FOnMouseEnter(Self);
  end;
end;

procedure TSkinButton.CMMouseLeave(var Msg: TMessage);
begin
  if Enabled
  then begin
    IsHover := false;
    Invalidate;
    if Assigned(FOnMouseLeave)
    then FOnMouseLeave(Self);
  end;
end;

procedure TSkinButton.CMFontChanged(var Msg: TMessage);
begin
  Invalidate;
end;

procedure TSkinButton.CMTextChanged(var Msg: TMessage);
begin
  Invalidate;
end;

procedure TSkinButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if Button = mbLeft
  then begin
    IsDown := true;
    Invalidate;
  end;
end;

procedure TSkinButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  if Button = mbLeft
  then begin
    IsDown := false;
    Invalidate;
  end;
end;

procedure TSkinButton.Click;
begin
  inherited Click;
  Down := not Down;
  Invalidate;
end;

procedure TSkinButton.DblClick;
begin
  inherited DblClick;
  Down := not Down;
  Invalidate;
end;

procedure TSkinButton.Paint;
var
  CanvasTop: Integer;
  CanvasLeft: Integer;
  CanvasRight: Integer;
  CanvasBottom: Integer;
  CanvasColorA: TColor;
  CanvasColorB: TColor;
  CurrentGlyph: ^TBitMap;
  BorderSize: Integer;
  X, Y: Integer;
begin
  if Border = sbNone
  then BorderSize := 0
  else BorderSize := 1;
  if Enabled
  then begin
    if Down or IsDown
    then begin
      if IsHover
      then begin
        CanvasColorA := clMedGray;
        CanvasColorB := clWhite;
        CurrentGlyph := Addr(GlyphDownHover);
      end else begin
        CanvasColorA := clGray;
        CanvasColorB := clWhite;
        CurrentGlyph := Addr(GlyphDownActive);
      end;
    end else begin
      if IsHover
      then begin
        CanvasColorA := clWhite;
        CanvasColorB := clMedGray;
        CurrentGlyph := Addr(GlyphUpHover);
      end else begin
        CanvasColorA := clWhite;
        CanvasColorB := clGray;
        CurrentGlyph := Addr(GlyphUpActive);
      end;
    end;
  end else begin
    if Down or IsDown
    then begin
      CanvasColorA := clMedGray;
      CanvasColorB := clWhite;
      CurrentGlyph := Addr(GlyphDownInactive);
    end else begin
      CanvasColorA := clWhite;
      CanvasColorB := clMedGray;
      CurrentGlyph := Addr(GlyphUpInactive);
    end;
  end;
  Canvas.Brush.Color := Color;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(Rect(0, 0, Width, Height));
  if not CurrentGlyph.Empty
  then begin
    if AutoSize
    then begin
      Width := CurrentGlyph.Width + ( 2 * BorderSize );
      Height := CurrentGlyph.Height + ( 2 * BorderSize );
      Canvas.Brush.Color := Color;
      Canvas.Brush.Style := bsSolid;
      Canvas.FillRect(Rect(0, 0, Width, Height));
    end;
    Canvas.CopyMode := cmSrcCopy;
    if Stretch
    then Canvas.StretchDraw(Rect(BorderSize, BorderSize, Width - BorderSize, Height - BorderSize), CurrentGlyph^)
    else Canvas.Draw(BorderSize, BorderSize, CurrentGlyph^);
  end;
  if Border = sbFlat
  then begin
    CanvasTop := 0;
    CanvasLeft := 0;
    CanvasRight := Width - 1;
    CanvasBottom := Height - 1;
    Canvas.Pen.Color := CanvasColorA;
    Canvas.MoveTo(CanvasLeft, CanvasBottom);
    Canvas.LineTo(CanvasLeft, CanvasTop);
    Canvas.LineTo(CanvasRight, CanvasTop);
    Canvas.Pen.Color := CanvasColorB;
    Canvas.MoveTo(CanvasRight, CanvasTop);
    Canvas.LineTo(CanvasRight, CanvasBottom);
    Canvas.LineTo(CanvasLeft - 1, CanvasBottom);
  end;
  if length(Caption) > 0
  then begin
    Canvas.Font := Font;
    Canvas.Brush.Color := Color;
    Canvas.Brush.Style := bsClear;
    X := Width - ( Canvas.TextWidth(Caption) div 2 + Width div 2 );
    Y := ( Height div 2 ) - ( Canvas.TextHeight(Caption) div 4 + 3 );
    if Down or IsDown
    then begin
      X := X + 1;
      Y := Y + 1;
    end;
    if Enabled
    then begin
      Canvas.Font.Color := clBtnText;
      Canvas.TextOut(X, Y, Caption);
    end else begin
      Canvas.Font.Color := clBtnHighLight;
      Canvas.TextOut(X + 1, Y + 1, Caption);
      Canvas.Font.Color := clBtnShadow;
      Canvas.TextOut(X, Y, Caption);
    end;
  end;
end;

procedure Register;
begin
  RegisterComponents('Additional', [TSkinButton]);
end;

end.

Conclusion :


j'ai fait le plus attention possible en l'écrivant, mais si il y a un bug ou que vous avez un conseil, n'hésitez pas en m'envoyer un petit mail ;o)

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

cs_grandvizir
Messages postés
1237
Date d'inscription
samedi 8 novembre 2003
Statut
Membre
Dernière intervention
3 septembre 2006
10 -
Pour le focus, il faut faire descendre de TCustomControl et non de TWinControl qui n'a aucun Canvas (ça serait embêtant). Ceci ne suffit pas, il faut publier les propriétés Enabled, Visible, TabOrder et TabStop.

Ensuite, tout se gère OnPaint avec l'appel: if Focused then DessineMoiUnBeauFocus;
cs_Nono40
Messages postés
1000
Date d'inscription
mercredi 3 avril 2002
Statut
Membre
Dernière intervention
12 septembre 2006
1 -
Pour le focus, il n'y a pas grand chose à faire, mise à part de descendre de TWinControl et de gérer le Focused. Je me souviens qu'il y a une ou deux autres petites choses à gérer mais je ne sais plus les-quelles
Sinon tu as raison, le focus n'est pas capital tant que l'on utilise pas le clavier. De plus les TGraphicControl utilisent moins de ressources que les TWinControl car ils n'ont pas de Handle de fenêtre.
cs_Nebula
Messages postés
790
Date d'inscription
samedi 8 juin 2002
Statut
Membre
Dernière intervention
7 juin 2007
1 -
en effet delphi m'avait signalé un avertissement pou le SetAutoSize ("warning: SetAutoSize method hides parent's method" si ma mémoire est bonne) mais je ne savais pas trop comment passer outre, j'appliquerais ta solution pour une future mise à jour ;o)

j'ai fait ce composant pour la version 2 d'un de mes programmes (celui de mon site en fait), et le focus n'est pas obligatoire même s'il serait appréciable... je suppose qu'il faut rajouter un "if Focused" dans la méthode Paint, et dessiner ainsi l'effet du focus sur le composant ?

en tout cas merci pour ton encouragement ;o)
cs_Nono40
Messages postés
1000
Date d'inscription
mercredi 3 avril 2002
Statut
Membre
Dernière intervention
12 septembre 2006
1 -
Et pour les félicitations il faut aussi être indulgent ?

Je n'ai que peu de remarques :
AutoSize existe déjà dans la classe de base TGraphicControl. Il suffit donc de la publier et de surcharger le SetAutosize :
Procedure SetAutosize (Value: Boolean );Override;
Juste pour effectuer un Invalidate en cas de changement.

Bravo pour cet exellent début...

P.S. : la prochaine version devrait descendre de TWinControl pour avoir la possiblité de détenir le focus.

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.