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)
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.