//有个与你想法相同的控键实例,自己看看吧!
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.
