lbbutton.pas

LBBottun for delphi7 按钮控件

unit LbButton;

interface

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

type
   TLbButton = class(TCustomControl)
   private
      FAlignment: TAlignment;
      FShadowColor: TColor;
      FCaption: TCaption;
      FColorWhenDown: TColor;
      FEnabled: boolean;
      FFlat: boolean;
      FGlyph: TBitmap;
      FHotTrackColor: TColor;
      FKind: TLbButtonKind;
      FLayout: TLbButtonLayout;
      FLightColor: TColor;
      FModalResult: TModalResult;
      FNumGlyphs: integer;
      FOnClick: TNotifyEvent;
      FOnMouseEnter: TNotifyEvent;
      FOnMouseExit: TNotifyEvent;
      FDummyStyle: TLbColorStyle;
      FStyle: TLbButtonStyle;
      FDefault, FCancel: boolean;

      bDown: boolean;
      bCursorOnButton: boolean;
   public
      constructor Create(aOwner: TComponent); override;
      destructor Destroy; override;
      procedure Click; override;
   protected
      procedure SetAlignment(fNew: TAlignment);
      procedure SetCaption(const fNew: TCaption);
      procedure SetEnabled(fNew: boolean); override;
      procedure SetFlat(fNew: boolean);
      procedure SetGlyph(fNew: TBitmap);
      procedure SetKind(fNew: TLbButtonKind);
      procedure SetLayout(fNew: TLbButtonLayout);
      procedure SetLightColor(fNew: TColor);
      procedure SetModalResult(fNew: TModalResult);
      procedure SetNumGlyphs(fNew: integer);
      procedure SetStyle(fNew: TLbButtonStyle);
      procedure SetShadowColor(fNew: TColor);
      procedure SetColorStyle(fNew: TLbColorStyle);

      procedure DoMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
      procedure DoMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
      procedure DoFocusChanged(var Msg: TMessage); message CM_FOCUSCHANGED;
      procedure DoKeyDown(var Msg: TMessage); message CN_KEYDOWN;
      procedure DoKeyUp(var Msg: TMessage); message CN_KEYUP;
      procedure DoDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
      procedure DoDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;

      procedure Paint; override;
      procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
      procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
   published
      property Align;
      property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;
      property ShadowColor: TColor read FShadowColor write SetShadowColor default clGray;
      property Cancel: boolean read FCancel write FCancel default false;
      property Caption: TCaption read FCaption write SetCaption;
      property Color;
      property ColorStyle: TLbColorStyle read FDummyStyle write SetColorStyle default lcsCustom;
      property ColorWhenDown: TColor read FColorWhenDown write FColorWhenDown default clNone;
      property Default: boolean read FDefault write FDefault default false;
      property DragCursor;
      property DragKind;
      property DragMode;
      property Enabled: boolean read FEnabled write SetEnabled default true;
      property Flat: boolean read FFlat write SetFlat default false;
      property Font;
      property Glyph: TBitmap read FGlyph write SetGlyph;
      property Hint;
      property HotTrackColor: TColor read FHotTrackColor write FHotTrackColor default clNone;
      property Kind: TLbButtonKind read FKind write SetKind default bkCustom;
      property Layout: TLbButtonLayout read FLayout write SetLayout default blGlyphLeft;
      property LightColor: TColor read FLightColor write SetLightColor default clWhite;
      property ModalResult: TModalResult read FModalResult write SetModalResult;
      property NumGlyphs: integer read FNumGlyphs write SetNumGlyphs default 0;
      property ParentColor;
      property ParentFont;
      property ParentShowHint;
      property PopupMenu;
      property ShowHint;
      property Style: TLbButtonStyle read FStyle write SetStyle default bsNormal;
      property TabOrder;
      property TabStop default true;
      property Visible;

      property OnClick: TNotifyEvent read FOnClick write FOnClick;
      property OnDragDrop;
      property OnDragOver;
      property OnEndDrag;
      property OnEnter;
      property OnExit;
      property OnKeyDown;
      property OnKeyPress;
      property OnKeyUp;
      property OnMouseDown;
      property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
      property OnMouseExit: TNotifyEvent read FOnMouseExit write FOnMouseExit;
      property OnMouseMove;
      property OnMouseUp;
      property OnStartDrag;
   end;

procedure Register;

implementation

{##############################################################################}

procedure Register;
begin
   RegisterComponents('LB', [TLbButton]);
end;

{##############################################################################}

constructor TLbButton.Create(aOwner: TComponent);
begin
   inherited;

   Height := 23;
   Width := 100;

   ControlStyle := [csSetCaption, csCaptureMouse];

   FGlyph := TBitmap.Create;

   bDown := false;
   bCursorOnButton := false;

   FLightColor := clWhite;
   FShadowColor := clGray;
   FColorWhenDown := clNone;
   FEnabled := true;
   FStyle := bsNormal;
   FKind := bkCustom;
   TabStop := true;
   FDummyStyle := lcsCustom;
   FHotTrackColor := clNone;
   FAlignment := taCenter;

   FDefault := false;
   FCancel := false;

   Color := clBtnFace;
end;

{##############################################################################}

destructor TLbButton.Destroy;
begin
   FGlyph.Free;
   inherited;
end;

{##############################################################################}

procedure TLbButton.Click;
begin 
   if Visible and Enabled then
   begin
      if assigned(FOnClick) then FOnClick(self);
      if FModalResult <> mrNone then GetParentForm(self).ModalResult := FModalResult;
      if assigned(PopupMenu) then PopupMenu.PopUp(ClientToScreen(Point(0, Height)).X, ClientToScreen(Point(0, Height)).Y);
   end;
end;

{##############################################################################}

procedure TLbButton.SetAlignment(fNew: TAlignment);
begin
   FAlignment := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetCaption(const fNew: TCaption);
begin
   FCaption := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetColorStyle(fNew: TLbColorStyle);
var
   bModern: boolean;
   FColor: TColor;

begin
   if fNew = lcsCustom then exit;

   GetPreDefinedColors(fNew, FColor, FLightColor, FShadowColor, FColorWhenDown, FHotTrackColor, FFlat, bModern);
   Color := FColor;
   if bModern then FStyle := bsModern else FStyle := bsNormal;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetEnabled(fNew: boolean);
begin
   FEnabled := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetFlat(fNew: boolean);
begin
   FFlat := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetGlyph(fNew: TBitmap);
begin
   if fNew <> nil then
   begin
      FGlyph.Assign(fNew);
      if fNew.Height <> 0 then FNumGlyphs := fNew.Width div fNew.Height else FNumGlyphs := 0;
   end
   else
   begin
      FGlyph.Height := 0;
      FNumGlyphs := 0;
   end;
   FKind := bkCustom;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetKind(fNew: TLbButtonKind);
begin
   if fNew <> bkCustom then FNumGlyphs := 2;
   case fNew of
      bkOK:     begin ModalResult := mrOK;      FGlyph.LoadFromResourceName(hInstance, 'LBOK');      FCaption := 'OK';           end;
      bkCancel: begin ModalResult := mrCancel;  FGlyph.LoadFromResourceName(hInstance, 'LBCANCEL');  FCaption := 'Abbrechen';    end;
      bkHelp:   begin ModalResult := mrNone;    FGlyph.LoadFromResourceName(hInstance, 'LBHELP');    FCaption := 'Hilfe';        end;
      bkYes:    begin ModalResult := mrYes;     FGlyph.LoadFromResourceName(hInstance, 'LBYES');     FCaption := 'Ja';           end;
      bkNo:     begin ModalResult := mrNo;      FGlyph.LoadFromResourceName(hInstance, 'LBNO');      FCaption := 'Nein';         end;
      bkClose:  begin ModalResult := mrNone;    FGlyph.LoadFromResourceName(hInstance, 'LBCLOSE');   FCaption := 'Schlie遝n';    end;
      bkAbort:  begin ModalResult := mrAbort;   FGlyph.LoadFromResourceName(hInstance, 'LBABORT');   FCaption := 'Abbrechen';    end;
      bkRetry:  begin ModalResult := mrRetry;   FGlyph.LoadFromResourceName(hInstance, 'LBRETRY');   FCaption := 'Wiederholen';  end;
      bkIgnore: begin ModalResult := mrIgnore;  FGlyph.LoadFromResourceName(hInstance, 'LBIGNORE');  FCaption := 'Ignorieren';   end;
      bkAll:    begin ModalResult := mrAll;     FGlyph.LoadFromResourceName(hInstance, 'LBALL');     FCaption := 'Alle';         end;
   end;

   FKind := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetLayout(fNew: TLbButtonLayout);
begin
   FLayout := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetNumGlyphs(fNew: integer);
begin
   FNumGlyphs := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetModalResult(fNew: TModalResult);
begin
   FModalResult := fNew;
   FKind := bkCustom;
end;

{##############################################################################}

procedure TLbButton.SetLightColor(fNew: TColor);
begin
   FLightColor := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetShadowColor(fNew: TColor);
begin
   FShadowColor := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.SetStyle(fNew: TLbButtonStyle);
begin
   FStyle := fNew;
   Paint;
end;

{##############################################################################}

procedure TLbButton.DoMouseEnter(var Msg: TMessage);
begin
   if assigned(FOnMouseEnter) then FOnMouseEnter(self);
   bCursorOnButton := true;
   Paint;
end;

{##############################################################################}

procedure TLbButton.DoMouseLeave(var Msg: TMessage);
begin
   if assigned(FOnMouseExit) then FOnMouseExit(self);
   bCursorOnButton := false;
   Paint;
end;

{##############################################################################}

procedure TLbButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   inherited;
   if Enabled then
   begin
      bDown := true;
      SetFocus;
      Paint;
   end;
end;

{##############################################################################}

procedure TLbButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   inherited;
   if bDown and bCursorOnButton then Click;
   bDown := false;
   Paint;
end;

{##############################################################################}

procedure TLbButton.DoFocusChanged(var Msg: TMessage);
begin
   Paint;
end;

{##############################################################################}

procedure TLbButton.DoKeyDown(var Msg: TMessage);
begin
   inherited;
   if Enabled then if Msg.WParam in [VK_SPACE, VK_RETURN] then
   begin
      bDown := true;
      Paint;
   end;
end;

{##############################################################################}

procedure TLbButton.DoKeyUp(var Msg: TMessage);
begin
   inherited;
   if Enabled then if Msg.WParam in [VK_SPACE, VK_RETURN] then if bDown then Click;
   bDown := false;
   Paint;
end;

{##############################################################################}

procedure TLbButton.Paint;
var
   aBitmap: TBitmap;          

begin
   if not (Visible or (csDesigning in ComponentState)) or (csLoading in ComponentState) then exit;

   if FStyle = bsModern then
      LbPaintButton(Canvas, Width, Height, FNumGlyphs, FGlyph, bDown, bCursorOnButton or focused, false, Enabled, Flat or not Enabled, assigned(PopupMenu), FStyle, Color, FColorWhenDown, FHotTrackColor, FLightColor, FShadowColor, Font, FLayout, FCaption, FAlignment)
   else
   begin
      // Draw on a Bitmap first, then just copy the Bitmap to the Canvas. Just to avoid flickering...
      aBitmap := TBitmap.Create;
      aBitmap.Height := Height;
      aBitmap.Width := Width;
      LbPaintButton(aBitmap.Canvas, Width, Height, FNumGlyphs, FGlyph, bDown, bCursorOnButton or focused, false, Enabled, Flat, assigned(PopupMenu), FStyle, Color, FColorWhenDown, FHotTrackColor, FLightColor, FShadowColor, Font, FLayout, FCaption, FAlignment);
      Canvas.Draw(0, 0, aBitmap);
      aBitmap.Free;
   end;
   if focused and enabled then Canvas.DrawFocusRect(Rect(4, 4, Width-4, Height - 4));
end;

{##############################################################################}

procedure TLbButton.DoDialogChar(var Message: TCMDialogChar);
begin
   with Message do
   begin
      if IsAccel(CharCode, Caption) and Visible and Enabled and (Parent <> nil) and Parent.Showing then
      begin
         bDown := false;
         Paint;
         Click;
         Result := 1;
      end
      else
         inherited;
   end;
end;

{##############################################################################}

procedure TLbButton.DoDialogKey(var Message: TCMDialogKey);
begin
   bDown := false;
   Paint;
   with Message do
   begin
      if ((CharCode = VK_RETURN) and FDefault) or ((CharCode = VK_ESCAPE) and FCancel) and (KeyDataToShiftState(Message.KeyData) = []) and Visible and Enabled then
      begin
         bDown := false;
         Paint;
         Click;
         Result := 1;
      end
      else
         inherited;
   end;
end;

{##############################################################################}

end.