fcbutton.pas

一套及时通讯的原码

unit fcButton;
{
//
// Components : TfcButton
//
// Copyright (c) 1999 by Woll2Woll Software
//
// Changes:
// RSW - 3/9/99 - Process default button when carriage return or Cancel entered
// 6/6/99 - Respect windows smooth font settings when painting text of buttons
// 6/8/99 - Improved support for painting flat style if dialog is shown in button's OnClick
// 7/13/99 - PYW - Changed to always process mouse up in fcoutlookbar
// 7/26/99 - Call click on space key
// 7/26/99 - setfocus when mouse clicked on button if focusable is true
// 11/17/99 - PYW - Don't HotTrack if form is not the active form.
// 2/22/00 - Disregard parent test if MDI form
// PYW - 5/1/00 - Added flag because sendmessage causes some recursion when using the OnMouseDown.  Specifically the MenuForm example project.
// PYW - 5/18/2000 - Don't exit if ParentForm was created using CreateParented.
// PYW - 6/2/2000 - Fix bug when using Raised ShadeStyle and the button's OnClick event to show a dialog.
// PYW - 6/19/2000 - Solve mousedown problems with nonfocusable buttons. Set BasePatch[1] := True to preserve old behavior.
// RSW - 7/6/00 - Resolve redline problem with some environments
// 7/31/00 - Disregard parent test for ActiveX forms
// 8/18/00 - Remove default as inconsistent with constructor
// 1/3/01 - Use SetButtonDown procedure so AllowAllUp is considered. -PYW
// 10/15/2001- Only set this if groupindex > 0.
// 12/20/2001 - Skip invisible controls. -PYW
// 6/17/02 - Support button painting in grid
}
interface

{$i fcIfDef.pas}

uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
  CommCtrl, Buttons, Dialogs, Math, Consts, SysUtils, fccommon, fcBitmap, fcChangeLink,
  TypInfo, dbctrls, db,
  {$ifdef fcDelphi7Up}
  Themes,
  {$endif}
  {$ifdef ThemeManager}
  thememgr, themesrv, uxtheme,
  {$endif}

  {$ifdef fcDelphi4Up}
  ImgList, ActnList,
  {$endif}
  {$ifdef fcdelphi6Up}
  variants,
  {$endif}
  fcText;

const DESIGN_KEY = VK_MENU;

type
  TfcShadeStyle = (fbsNormal, fbsRaised, fbsHighlight, fbsFlat);

  TfcButtonOption = (boFocusable, boOverrideActionGlyph, boToggleOnUp,
    boFocusRect, boAutoBold);
  TfcButtonOptions = set of TfcButtonOption;

  TfcCustomBitBtn = class;
  TfcCustomBitBtnClass = class of TfcCustomBitBtn;

  TfcRegionData = record
    dwSize: Integer;
    rgnData: PRgnData;
  end;
  PfcRegionData = ^TfcRegionData;

  TfcOffsets =  class(TPersistent)
  private
    // Property Storage Variables
    FControl: TWinControl;
    FGlyphX: Integer;
    FGlyphY: Integer;
    FTextX: Integer;
    FTextY: Integer;
    FTextDownX: Integer;
    FTextDownY: Integer;
    procedure SetGlyphX(Value: Integer);
    procedure SetGlyphY(Value: Integer);
    procedure SetTextX(Value: Integer);
    procedure SetTextY(Value: Integer);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    property Control: TWinControl read FControl;
  public
    constructor Create(Button: TfcCustomBitBtn);
  published
    property GlyphX: Integer read FGlyphX write SetGlyphX default 0;
    property GlyphY: Integer read FGlyphY write SetGlyphY default 0;
    property TextX: Integer read FTextX write SetTextX default 0;
    property TextY: Integer read FTextY write SetTextY default 0;
    property TextDownX: Integer read FTextDownX write FTextDownX default 1;
    property TextDownY: Integer read FTextDownY write FTextDownY default 1;
  end;

  TfcShadeColors = class(TPersistent)
  private
    FButton: TfcCustomBitBtn;
    FBtnHighlight: TColor;
    FBtn3dLight: TColor;
    FBtnShadow: TColor;
    FBtnBlack: TColor;
    FBtnFocus: TColor;
    FShadow: TColor;
    procedure SetBtn3DLight(Value: TColor);
    procedure SetBtnBlack(Value: TColor);
    procedure SetBtnHighlight(Value: TColor);
    procedure SetBtnShadow(Value: TColor);
    procedure SetBtnFocus(Value: TColor);
    procedure SetShadow(Value: TColor);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(Button: TfcCustomBitBtn);
  published
    property Btn3DLight: TColor read FBtn3DLight write SetBtn3DLight default cl3DLight;
    property BtnHighlight: TColor read FBtnHighlight write SetBtnHighlight default clBtnHighlight;
    property BtnShadow: TColor read FBtnShadow write SetBtnShadow default clBtnShadow;
    property BtnBlack: TColor read FBtnBlack write SetBtnBlack default clBlack;
    property BtnFocus: TColor read FBtnFocus write SetBtnFocus default clBlack;
    property Shadow: TColor read FShadow write SetShadow default clBlack;
  end;

  TfcCustomBitBtn = class(TWinControl)
  private
    // Property Storage Variables
    FActive: Boolean;
    FAllowAllUp: Boolean;
    FCancel: Boolean;
    FDefault: Boolean;
    FDown: Boolean;
    FGlyph: TBitmap;
    FGroupIndex: Integer;
    FInMouseSendForMouseActivate:Boolean;
    FKind: TBitBtnKind;
    FLayout: TButtonLayout;
    FMargin: Integer;
    FModalResult: TModalResult;
    FNumGlyphs: TNumGlyphs;
    FRegion, FLastRegion: HRgn;
    FShadeColors: TfcShadeColors;
    FShadeStyle: TfcShadeStyle;  // Published
    FShowFocusRect: Boolean;
    FSpacing: Integer;
    FStyle: TButtonStyle;
    FTextOptions: TfcCaptionText;
    {$ifdef fcDelphi4Up}
    FSmoothFont: boolean;
    {$endif}

    FGlyphRect: TRect;
    FTextRect: TRect;

    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FOnSelChange: TNotifyEvent;
    FOnSetName: TNotifyEvent;

    FCanvas: TCanvas;
    FOffsets: TfcOffsets;
    FModifiedGlyph: Boolean;
    FOptions: TfcButtonOptions;
    FChangeLinks: TList;
    FChangeLink: TfcChangeLink;
    FClicked: Boolean;
    FInitialDown: Boolean;
    FEvents: TStringList;
    FUseHalftonePalette: boolean;
    FShowDownAsUp:boolean;
    FHot: boolean;
    FDataLink: TFieldDataLink;
    FDisableThemes: boolean;
    FStaticCaption: boolean;

    // Property Access Methods
    function GetKind: TBitBtnKind;
    procedure SetAllowAllUp(Value: Boolean);
    procedure SetButtonDown(Value: Boolean; CheckAllowAllUp: Boolean; DoUpdateExclusive: Boolean; DoInvalidate: Boolean);
    procedure SetDefault(Value: Boolean);
    procedure SetDown(Value: Boolean);
    procedure SetGlyph(Value: TBitmap);
    procedure SetGroupIndex(Value: Integer);
    procedure SetKind(Value: TBitBtnKind);
    procedure SetLayout(Value: TButtonLayout);
    procedure SetMargin(Value: Integer);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure SetOptions(Value: TfcButtonOptions);
    procedure SetSpacing(Value: Integer);
    procedure SetShadeStyle(Value: TfcShadeStyle);
    procedure SetStyle(Value: TButtonStyle);

    // Message Handlers
    procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE;
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
    procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
    procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure ProcessMouseUp(X, Y: Integer; AMouseInControl: Boolean; AClicked: Boolean);
    procedure ProcessMouseDown;
    function GetDataField: string;
    function GetDataSource: TDataSource;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
  protected
    FDownRegionData: TfcRegionData;
    FRegionData: TfcRegionData;
    FSelected: Boolean;
    DisableButton: boolean;

    function GetField: TField;
    function GetDBCaption: string; virtual;
//    procedure SetCaption(val: string); virtual;
    // Overriden Methods
    function GetPalette: HPALETTE; override;
    {$ifdef fcDelphi4Up}
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    {$endif}
    procedure AssignTo(Dest: TPersistent); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure Loaded; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure SetName(const Value: TComponentName); override;

    // Virtual Methods
    procedure GetEvents(const s: string);
    function CreateOffsets: TfcOffsets; virtual;
    function CreateRegion(DoImplementation: Boolean; Down: Boolean): HRgn; virtual;
    function CalcButtonLayout(Canvas: TCanvas; Client: TRect; var TextRect: TRect;
      var GlyphRect: TRect; TextSize: TSize): TRect; virtual;
    function GlyphWidth: Integer; virtual;
    function IsCustom: Boolean; virtual;
    function IsCustomCaption: Boolean; virtual;
    function MouseInControl(X, Y: Integer; AndClicked: Boolean): Boolean;
    function StoreRegionData: Boolean; virtual;
    procedure ChangeButtonDown; virtual;
    procedure CleanUp; virtual;
    procedure ClearRegion(ARgnData: PfcRegionData); virtual;
    procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint); virtual;
    procedure DrawButtonText(Canvas: TCanvas; TextBounds: TRect); virtual;
    procedure DrawItem(const DrawItemStruct: TDrawItemStruct); virtual;
    procedure GetDrawBitmap(DrawBitmap: TfcBitmap; ForRegion: Boolean;
      ShadeStyle: TfcShadeStyle; Down: Boolean); virtual;
    procedure GlyphChanged(Sender: TObject); virtual;
    procedure NotifyChange; virtual;
    procedure NotifyChanging; virtual;
    procedure NotifyLoaded; virtual;
    procedure Paint; virtual;
    procedure Redraw; virtual;
    procedure ReadRegionData(Stream: TStream); virtual;
    procedure ReadDownRegionData(Stream: TStream); virtual;
    procedure SaveRegion(NewRegion: Longword; Down: Boolean); virtual;
    procedure SelChange; virtual;
//    procedure WriteState(Writer: TWriter); override;
    procedure WndProc(var Message: TMessage); override;
    procedure WriteRegionData(Stream: TStream); virtual;
    procedure WriteDownRegionData(Stream: TStream); virtual;
    procedure UpdateExclusive; virtual;
    function UseRegions: boolean; virtual;

    // Protected Properties
    property Active: Boolean read FActive;
    property Canvas: TCanvas read FCanvas;
    property GlyphRect: TRect read FGlyphRect;
    property TextRect: TRect read FTextRect;
    property InitalDown: Boolean read FInitialDown;
    property Clicked: Boolean read FClicked;
    procedure DataChange(Sender: TObject); virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    BasePatch: Variant;
    property Region: HRGN read FRegion;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    // Virtual Methods
    procedure ApplyRegion; virtual;
    procedure InvalidateNotRegion(const Erase: Boolean); virtual;

    function Draw(Canvas: TCanvas): TRect; virtual;
    function IsMultipleRegions: Boolean; virtual;
    procedure Click; override;
    procedure SizeToDefault; virtual;
    procedure UpdateShadeColors(Color: TColor); virtual;

    procedure RegisterChanges(Value: TfcChangeLink); virtual;
    procedure UnRegisterChanges(Value: TfcChangeLink); virtual;

    function GetTextEnabled: Boolean; virtual;
    procedure AdjustBounds; virtual;

    // Public Properties
    property ShowDownAsUp: Boolean read FShowDownAsUp write FShowDownAsUp default False;

    property StaticCaption: boolean read FStaticCaption write FStaticCaption default False;
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
    property Cancel: Boolean read FCancel write FCancel default False;
    property Caption {: string read GetCaption write SetCaption }stored IsCustomCaption;
    property Color;
    property Default: Boolean read FDefault write SetDefault default False;
    property Down: Boolean read FDown write SetDown default False;
    property Font;
    property Offsets: TfcOffsets read FOffsets write FOffsets;
    property Glyph: TBitmap read FGlyph write SetGlyph stored IsCustom;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
    property Kind: TBitBtnKind read GetKind write SetKind default bkCustom;
    property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
    property Margin: Integer read FMargin write SetMargin default -1;
    property ModalResult: TModalResult read FModalResult write FModalResult default 0;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs stored IsCustom default 1;
    property Options: TfcButtonOptions read FOptions write SetOptions default [];
    property Selected: Boolean read FSelected;
    property ShadeColors: TfcShadeColors read FShadeColors write FShadeColors;
    property ShadeStyle: TfcShadeStyle read FShadeStyle write SetShadeStyle;
    {$ifdef fcDelphi4Up}
    property SmoothFont: boolean read FSmoothFont write FSmoothFont default false;
    {$endif}
    property Style: TButtonStyle read FStyle write SetStyle default bsAutoDetect;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property TabStop; // 8/18/00 - Remove default as inconsistent with constructor
    property TextOptions: TfcCaptionText read FTextOptions write FTextOptions;
    property OnClick;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnSelChange: TNotifyEvent read FOnSelChange write FOnSelChange;
    property OnSetName: TNotifyEvent read FOnSetName write FOnSetName;
    property UseHalftonePalette: Boolean read FUseHalftonePalette write FUseHalftonePalette;
    property Hot : boolean read FHot write FHot;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property DataLink: TFieldDataLink read FDataLink;
    property Field: TField read GetField;
    property DisableThemes : boolean read FDisableThemes write FDisableThemes default False;
  end;

implementation

{$r fcButtns.RES}

const
  BITBTNMODALRESULTS: array[TBitBtnKind] of TModalResult = (
    0, mrOk, mrCancel, 0, mrYes, mrNo, 0, mrAbort, mrRetry, mrIgnore,
    mrAll);

var
  BitBtnResNames: array[TBitBtnKind] of PChar = (
    nil, 'WWOK', 'WWCANCEL', 'WWHELP', 'WWYES', 'WWNO', 'WWCLOSE',
    'WWABORT', 'WWRETRY', 'WWIGNORE', 'WWALL');
  BitBtnCaptions: array[TBitBtnKind] of Pointer = (nil, nil, nil,
    nil, nil, nil, nil, nil, nil, nil, nil);
  BitBtnGlyphs: array[TBitBtnKind] of TBitmap;

procedure GetBitBtnGlyph(Kind: TBitBtnKind; Bitmap: TBitmap);
begin
  if BitBtnGlyphs[Kind] = nil then
  begin
    BitBtnGlyphs[Kind] := TBitmap.Create;
    BitBtnGlyphs[Kind].LoadFromResourceName(HInstance, BitBtnResNames[Kind]);
  end;
  Bitmap.Assign(BitBtnGlyphs[Kind]);
end;

// TfcDownOffsets

constructor TfcOffsets.Create(Button: TfcCustomBitBtn);
begin
  inherited Create;
  FControl := Button;
  FTextDownX := 1;
  FTextDownY := 1;
end;

procedure TfcOffsets.AssignTo(Dest: TPersistent);
begin
  if Dest is TfcOffsets then