lbspeedbutton.pas

LBBottun for delphi7 按钮控件

unit LbSpeedButton;

interface

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

type
   TLbSpeedButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
   TLbSpeedButtonStyle = (bsNormal, bsEncarta, bsModern);

   TLbSpeedButton = class(TGraphicControl)
   private
      FAlignment: TAlignment;
      FAllowAllUp: boolean;
      FCaption: TCaption;
      FColorWhenDown: TColor;
      FDown: boolean;
      FFlat: boolean;
      FGlyph: TBitmap;
      FGroupIndex: integer;
      FHotTrackColor: TColor;
      FLayout: TLbSpeedButtonLayout;
      FLightColor: TColor;
      FNumGlyphs: integer;
      FShadowColor: TColor;
      FStyle: TLbSpeedButtonStyle;
      FTransparent: boolean;
      FOnMouseEnter: TNotifyEvent;
      FOnMouseExit: TNotifyEvent;
      FDummyStyle: TLbColorStyle;

      bCursorOnButton: boolean;
   public
      constructor Create(aOwner: TComponent); override;
      destructor Destroy; override;
      procedure Click; override;
   protected
      procedure Paint; override;

      procedure SetAlignment(fNew: TAlignment);
      procedure SetFlat(fNew: boolean);
      procedure SetColorWhenDown(fNew: TColor);
      procedure SetColorStyle(fNew: TLbColorStyle);
      procedure SetDown(fNew: boolean);
      procedure SetCaption(const fNew: TCaption);
      procedure SetGlyph(fNew: TBitmap);
      procedure SetGroupIndex(fNew: integer);
      procedure SetLayout(fNew: TLbSpeedButtonLayout);
      procedure SetLightColor(fNew: TColor);
      procedure SetNumGlyphs(fNew: integer);
      procedure SetShadowColor(fNew: TColor);
      procedure SetStyle(fNew: TLbSpeedButtonStyle);
      procedure SetTransparent(fNew: boolean);

      procedure DoMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
      procedure DoMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
      procedure DoDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;

      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 taLeftJustify;
      property AllowAllUp: boolean read FAllowAllUp write FAllowAllUp default false;
      property Caption: TCaption read FCaption write SetCaption;
      property Color;
      property ColorWhenDown: TColor read FColorWhenDown write SetColorWhenDown default clNone;
      property ColorStyle: TLbColorStyle read FDummyStyle write SetColorStyle default lcsCustom;
      property Down: boolean read FDown write SetDown default false;
      property Enabled;
      property Flat: boolean read FFlat write SetFlat default false;
      property Font;
      property Glyph: TBitmap read FGlyph write SetGlyph;
      property GroupIndex: integer read FGroupIndex write SetGroupIndex default 0;
      property HotTrackColor: TColor read FHotTrackColor write FHotTrackColor default clNone;
      property Hint;
      property Layout: TLbSpeedButtonLayout read FLayout write SetLayout default blGlyphLeft;
      property LightColor: TColor read FLightColor write SetLightColor default clWhite;
      property NumGlyphs: integer read FNumGlyphs write SetNumGlyphs default 0;
      property ParentColor;
      property ParentFont;
      property ParentShowHint;
      property PopupMenu;
      property ShadowColor: TColor read FShadowColor write SetShadowColor default clBlack;
      property ShowHint;
      property Style: TLbSpeedButtonStyle read FStyle write SetStyle default bsNormal;
      property Transparent: boolean read FTransparent write SetTransparent default false;
      property Visible;

      property OnClick;
      property OnDblClick;
      property OnMouseDown;
      property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
      property OnMouseExit: TNotifyEvent read FOnMouseExit write FOnMouseExit;
      property OnMouseMove;
      property OnMouseUp;
   end;

procedure Register;

implementation

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

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

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

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

   ControlStyle := ControlStyle + [csSetCaption];
   ControlStyle := ControlStyle - [csOpaque];

   Height := 23;
   Width := 100;

   bCursorOnButton := false;
   FLightColor := clWhite;
   FShadowColor := clBlack;
   FColorWhenDown := clNone;
   FHotTrackColor := clNone;
   FAlignment := taLeftJustify;
   FDummyStyle := lcsCustom;

   FGlyph := TBitmap.Create;
end;

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

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

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

procedure TLbSpeedButton.SetAlignment(fNew: TAlignment);
begin
   FAlignment := fNew;
   if FTransparent then invalidate else paint;  // Could have generally used invalidate, but why make it flicker if it is not transparent?
end;

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

procedure TLbSpeedButton.SetCaption(const fNew: TCaption);
begin
   FCaption := fNew;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.SetColorWhenDown(fNew: TColor);
begin
   FColorWhenDown := fNew;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.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 TLbSpeedButton.SetDown(fNew: boolean);
var
   i: integer;

begin
   if FDown = fNew then exit;

   // If grouped, set all siblings to down=false
   if GroupIndex <> 0 then
      for i := 0 to Parent.ControlCount-1 do
         if Parent.Controls[i] is TLbSpeedButton then
            if TLbSpeedButton(Parent.Controls[i]).GroupIndex = GroupIndex then
               if TLbSpeedButton(Parent.Controls[i]) <> self then
                  TLbSpeedButton(Parent.Controls[i]).Down := false;

   FDown := fNew;

   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.SetFlat(fNew: boolean);
begin
   FFlat := fNew;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.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;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.SetGroupIndex(fNew: integer);
begin
   FGroupIndex := fNew;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.SetLayout(fNew: TLbSpeedButtonLayout);
begin
   FLayout := fNew;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.SetLightColor(fNew: TColor);
begin
   FLightColor := fNew;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.SetNumGlyphs(fNew: integer);
begin
   FNumGlyphs := fNew;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.SetShadowColor(fNew: TColor);
begin
   FShadowColor := fNew;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.SetStyle(fNew: TLbSpeedButtonStyle);
begin
   if GetDeviceCaps(Canvas.Handle, BITSPIXEL) <= 8 then if not (csDesigning in ComponentState) then fNew := bsNormal;
   FStyle := fNew;
   if fNew = bsModern then FAlignment := taCenter;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.SetTransparent(fNew: boolean);
begin
   FTransparent := fNew;
   if FTransparent then invalidate else paint;
end;

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

procedure TLbSpeedButton.Paint;
var
   aStyle: TLbButtonStyle;
   aLayout: TLbButtonLayout;
   aBitmap: TBitmap;

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

   aStyle := LbButtons.bsNormal;
   case FStyle of
      bsEncarta:  aStyle := LbButtons.bsEncarta;
      bsModern:   aStyle := LbButtons.bsModern;
   end;

   aLayout := LbButtons.blGlyphLeft;
   case FLayout of
      blGlyphTop:    aLayout := LbButtons.blGlyphTop;
      blGlyphRight:  aLayout := LbButtons.blGlyphRight;
      blGlyphBottom: aLayout := LbButtons.blGlyphBottom;
   end;

   if FTransparent or (FStyle = bsModern) then
   begin
      LbPaintButton(Canvas, Width, Height, FNumGlyphs, FGlyph, FDown, bCursorOnButton, FTransparent, Enabled, Flat, assigned(PopupMenu), aStyle, Color, FColorWhenDown, FHotTrackColor, FLightColor, FShadowColor, Font, aLayout, FCaption, FAlignment);
   end
   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, FDown, bCursorOnButton, false, Enabled, Flat, assigned(PopupMenu), aStyle, Color, FColorWhenDown, FHotTrackColor, FLightColor, FShadowColor, Font, aLayout, FCaption, FAlignment);
      Canvas.Draw(0, 0, aBitmap);
      aBitmap.Free;
   end;
end;

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

procedure TLbSpeedButton.DoMouseEnter(var Msg: TMessage);
begin
   bCursorOnButton := true;
   if FTransparent then invalidate else paint;
   if assigned(FOnMouseEnter) then FOnMouseEnter(self);
end;

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

procedure TLbSpeedButton.DoMouseLeave(var Msg: TMessage);
begin
   bCursorOnButton := false;
   if FTransparent then invalidate else paint;
   if assigned(FOnMouseExit) then FOnMouseExit(self);
end;

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

procedure TLbSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   inherited;
   if GroupIndex = 0 then Down := true
   else
   begin
      if Down then
      begin
         if FAllowAllUp then Down := false;
      end
      else
         Down := true;
   end;
end;

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

procedure TLbSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   inherited;
   if GroupIndex = 0 then Down := false;
end;

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

procedure TLbSpeedButton.DoDialogChar(var Message: TCMDialogChar);
var
   bWasDown: boolean;

begin
   with Message do
   begin
      if IsAccel(CharCode, Caption) and Enabled and Visible and (Parent <> nil) and Parent.Showing then
      begin
         bWasDown := Down;
         Down := true;
         Paint;
         Click;
         Down := bWasDown;
         Paint;
         Result := 1;
      end
      else
         inherited;
   end;
end;

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

procedure TLbSpeedButton.Click;
begin
   if assigned(PopupMenu) then PopupMenu.PopUp(ClientToScreen(Point(0, Height)).X, ClientToScreen(Point(0, Height)).Y);
   inherited;  // just to make it public :-)
end;

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

end.