Recull Components Delphi

Aquest blog és un recull de components Delphi de tot tipus. Hi apareixeran components gràfics, de comunicacions, de sistema...

Tuesday, January 23, 2007

ColorButton i ColorSpeedButton

Aquests components són una modificació sobre els components Button i SpeedButton per poder canviar-los de color.

unit TtButton;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DsgnIntf,
  ShellAPI, StdCtrls, Buttons;

type
  TColorButton = class(TCustomControl)
  private
    { Private declarations }
    FCaption: string;
    FFont: TFont;
    FColor: TColor;
    FWidthTop,FWidthDown: integer;
    FGlyph: TBitmap;
    FParentColor: boolean;
    FBitmap: TBitmap;
    procedure SetCaption(Value: string);
    procedure SetFont(Value: TFont);
    procedure SetColor(Value: TColor);
    procedure SetParentColor(AParentColor: boolean);
  protected
    { Protected declarations }
    procedure SetGlyph(Value: TBitmap);
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure KeyPress(var Key: Char); override;
    procedure DoExit; override;
    procedure DoEnter; override;
    procedure Click; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Caption: string read FCaption write SetCaption;
    property Font: TFont read FFont write SetFont;
    property Color: TColor read FColor write SetColor;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property Action;
    property Anchors;
    property BidiMode;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ParentBiDiMode;
    property ParentColor: boolean read FParentColor write SetParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

type
  TColorSpeedButton = class(TGraphicControl)
  private
    { Private declarations }
    FCaption: string;
    FFont: TFont;
    FColor: TColor;
    FTopColor,FBottomColor: integer;
    FGlyph: TBitmap;
    FParentColor: boolean;
    FBitmap: TBitmap;
    procedure SetCaption(Value: string);
    procedure SetFont(Value: TFont);
    procedure SetColor(Value: TColor);
    procedure SetParentColor(AParentColor: boolean);
  protected
    { Protected declarations }
    procedure SetGlyph(Value: TBitmap);
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Caption: string read FCaption write SetCaption;
    property Font: TFont read FFont write SetFont;
    property Color: TColor read FColor write SetColor;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property Action;
    property Anchors;
    property BidiMode;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ParentBiDiMode;
    property ParentColor: boolean read FParentColor write SetParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

constructor TColorButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FColor := clSilver;
  FFont := TFont.Create;
  FFont.Assign(Canvas.Font);
  TabStop := True;
  FWidthTop := 2;
  FWidthDown := 4;
  Width := 75;
  Height := 25;
  FGlyph := TBitmap.Create;
  FParentColor := False;
  FBitmap := TBitmap.Create;
end;

destructor TColorButton.Destroy;
begin
  FFont.Free;
  FGlyph.Free;
  FBitmap.Free;
  inherited Destroy;
end;

procedure TColorButton.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
  Invalidate;
end;

procedure TColorButton.SetParentColor(AParentColor: boolean);
begin
  FParentColor := AParentColor;
  Paint;
end;

const
  BORDER_FOCUS = 4;

procedure TColorButton.Paint;
var
  i: integer;
begin
  FBitmap.Width:=Width;
  FBitmap.Height:=Height;
  with FBitmap.Canvas do
  begin
    Font.Assign(FFont);
    if FParentColor=False then
      Brush.Color := FColor
    else
      Brush.Color := Parent.Brush.Color;
    FBitmap.Canvas.FillRect(ClientRect);
    if Focused then
    begin
      //external border
      Pen.Style := psSolid;
Pen.Color := clWhite;
      Pen.Width := 1;
   FBitmap.Canvas.MoveTo(1,1);
     FBitmap.Canvas.LineTo(Width-3,1);
FBitmap.Canvas.MoveTo(1,1);
   FBitmap.Canvas.LineTo(1,Height-1);
      Pen.Style := psSolid;
      Pen.Width := FWidthTop;
Pen.Color := clBlack;
   FBitmap.Canvas.MoveTo(0,0);
     FBitmap.Canvas.LineTo(Width,0);
FBitmap.Canvas.MoveTo(0,0);
   FBitmap.Canvas.LineTo(0,Height);
      Pen.Width := FWidthDown;
FBitmap.Canvas.MoveTo(0,Height);
   FBitmap.Canvas.LineTo(Width,Height);
     FBitmap.Canvas.MoveTo(Width,0);
FBitmap.Canvas.LineTo(Width,Height);
      //internal line
Pen.Color := clBlack;
      Pen.Width := 1;
      Pen.Style := psSolid;
      for i:=BORDER_FOCUS to Width-BORDER_FOCUS do
      begin
FBitmap.Canvas.MoveTo(i,BORDER_FOCUS);
      if (i mod 2)=0 then
        FBitmap.Canvas.LineTo(i+1,BORDER_FOCUS);
      end;
      for i:=BORDER_FOCUS to Height-BORDER_FOCUS do
      begin
FBitmap.Canvas.MoveTo(BORDER_FOCUS,i);
      if (i mod 2)=0 then
        FBitmap.Canvas.LineTo(BORDER_FOCUS,i+1);
      end;
      for i:=BORDER_FOCUS to Width-BORDER_FOCUS do
      begin
FBitmap.Canvas.MoveTo(i,Height-BORDER_FOCUS);
      if (i mod 2)=0 then
        FBitmap.Canvas.LineTo(i+1,Height-BORDER_FOCUS);
      end;
      for i:=BORDER_FOCUS to Height-BORDER_FOCUS do
      begin
FBitmap.Canvas.MoveTo(Width-BORDER_FOCUS,i);
      if (i mod 2)=0 then
        FBitmap.Canvas.LineTo(Width-BORDER_FOCUS,i+1);
      end;
    end
    else
    begin
      Pen.Width := 2;
Pen.Color := clWhite;
   FBitmap.Canvas.MoveTo(0,0);
     FBitmap.Canvas.LineTo(Width,0);
FBitmap.Canvas.MoveTo(0,0);
   FBitmap.Canvas.LineTo(0,Height);
     Pen.Color := clBlack;
      Pen.Width := 4;
FBitmap.Canvas.MoveTo(0,Height);
   FBitmap.Canvas.LineTo(Width,Height);
     FBitmap.Canvas.MoveTo(Width,0);
FBitmap.Canvas.LineTo(Width,Height);
    end;
    Brush.Style := bsClear;
    FGlyph.Transparent := True;
    if (FGlyph.Width<>0) and (FCaption<>'') then
    begin
      FBitmap.Canvas.TextOut((width - TextWidth(FCaption) - FGlyph.Width) div 2 + FGlyph.Width + 5, (height - TextHeight(FCaption)) div 2 , FCaption);
      FBitmap.Canvas.Draw((width - TextWidth(FCaption) - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
    end
    else
    if FGlyph.Width=0 then
    begin
      FBitmap.Canvas.TextOut((width - TextWidth(FCaption)) div 2, (height - TextHeight(FCaption)) div 2 , FCaption);
    end
    else
    begin
      FBitmap.Canvas.Draw((width - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
    end;
  end;
  Canvas.Draw(0,0,FBitmap);
end;

procedure TColorButton.SetCaption(Value: string);
begin
  FCaption := Value;
  Paint;
end;

procedure TColorButton.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
  Paint;
end;

procedure TColorButton.SetColor(Value: TColor);
begin
  FColor := Value;
  Paint;
end;

procedure TColorButton.DoExit;
begin
  Paint;
end;

procedure TColorButton.DoEnter;
begin
  Paint;
end;

procedure TColorButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FWidthTop := 4;
  FWidthDown := 2;
  SetFocus;
  Paint;
end;

procedure TColorButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FWidthTop := 2;
  FWidthDown := 4;
  Paint;
end;

procedure TColorButton.Click;
begin
  inherited;
end;

procedure TColorButton.KeyPress(var Key: Char);
begin
  FWidthTop := 4;
  FWidthDown := 2;
  Paint;
  if (Key=#13) or (Key=' ') then
     Click;
  FWidthTop := 2;
  FWidthDown := 4;
  Paint;
end;

constructor TColorSpeedButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FColor := clSilver;
  FFont := TFont.Create;
  FFont.Assign(Canvas.Font);
FTopColor := clWhite;
  FBottomColor := clBlack;
  Width := 22;
  Height := 22;
  FGlyph := TBitmap.Create;
  ParentFont := True;
  FCaption := '';
  FParentColor := False;
  FBitmap := TBitmap.Create;
end;

destructor TColorSpeedButton.Destroy;
begin
  FFont.Free;
  FGlyph.Free;
  FBitmap.Free;
  inherited Destroy;
end;

procedure TColorSpeedButton.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
  Invalidate;
end;

procedure TColorSpeedButton.Paint;
begin
  FBitmap.Width:=Width; {Ajustamos nuestro bitmap}
  FBitmap.Height:=Height;
  with FBitmap.Canvas do
  begin
    Font.Assign(FFont);
    if FParentColor=False then
      Brush.Color := FColor
    else
      Brush.Color := Parent.Brush.Color;
    FBitmap.Canvas.FillRect(ClientRect);
    Pen.Width := 2;
    Pen.Color := FTopColor;
  FBitmap.Canvas.MoveTo(0,0);
    FBitmap.Canvas.LineTo(Width,0);
    FBitmap.Canvas.MoveTo(0,0);
  FBitmap.Canvas.LineTo(0,Height);
    Pen.Color := FBottomColor;
    Pen.Width := 4;
    FBitmap.Canvas.MoveTo(0,Height);
  FBitmap.Canvas.LineTo(Width,Height);
    FBitmap.Canvas.MoveTo(Width,0);
    FBitmap.Canvas.LineTo(Width,Height);
    FGlyph.Transparent := True;
    if (FGlyph.Width<>0) and (FCaption<>'') then
    begin
      FBitmap.Canvas.TextOut((width - TextWidth(FCaption) - FGlyph.Width) div 2 + FGlyph.Width + 5, (height - TextHeight(FCaption)) div 2 , FCaption);
      FBitmap.Canvas.Draw((width - TextWidth(FCaption) - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
    end
    else
    if FGlyph.Width=0 then
    begin
      FBitmap.Canvas.TextOut((width - TextWidth(FCaption)) div 2, (height - TextHeight(FCaption)) div 2 , FCaption);
    end
    else
    begin
      FBitmap.Canvas.Draw((width - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
    end;
  end;
  Canvas.Draw(0,0,FBitmap);
end;

procedure TColorSpeedButton.SetCaption(Value: string);
begin
  FCaption := Value;
  Paint;
end;

procedure TColorSpeedButton.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
  Paint;
end;

procedure TColorSpeedButton.SetColor(Value: TColor);
begin
  FColor := Value;
  Paint;
end;

procedure TColorSpeedButton.SetParentColor(AParentColor: boolean);
begin
  FParentColor := AParentColor;
  Paint;
end;

procedure TColorSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FTopColor := clBlack;
  FBottomColor := clWhite;
  Paint;
end;

procedure TColorSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FTopColor := clWhite;
  FBottomColor := clBlack;
  Paint;
end;

procedure Register;
begin
  RegisterComponents('Components Delphi', [TColorButton]);
  RegisterComponents('Components Delphi', [TColorSpeedButton]);
end;

end.

La propietat Color fa que el botó canvïi de color.

# posted by jpuigpelat : 12:13 AM

Links

• Softcatala
• Vilaweb
• Internauta
• Debian Linux

  ---

• Tectrol

  ---

• Excursions per Catalunya
• Coses de la Xarxa

Archives

• December 2006
• January 2007
• February 2007