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

Télécharger le projet
Commenter

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)
Télécharger le projet

Codes Sources

S'inscrire maintenant

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.

Du même auteur (cs_Nebula)