myautobtn.pas

自动适应简繁体的TBitbtn按钮,并有类似XP风格的外观

unit MyAutoBtn;

{$S-,W-,R-,H+,X+}
{$C PRELOAD}

interface

uses
  Windows,
  Messages,
  Classes,
  Controls,
  Graphics,
  StdCtrls,
  ExtCtrls,
  CommCtrl,
  Math,
  Forms,
  menus,
  myCommon;

type
  TMySpeedButton = class(TGraphicControl)
  private
    FGroupIndex: Integer;
    FGlyph: Pointer;
    FInColor,FLeaveColor: TColor;
    FDown: Boolean;
    FDragging: Boolean;
    FAllowAllUp: Boolean;
    FLayout: TautoButtonLayout;
    FSpacing: Integer;
    FTransparent: Boolean;
    FMargin: Integer;
    FFlat,FBordFlat: Boolean;
    FMouseInControl: Boolean;
    FCurtext:string;

    FOnSelfDblClickEvent: TMySelfDblClickEvent;
    FOnSelfEnterEvent: TMySelfEnterEvent;
    FOnSelfExitEvent: TMySelfExitEvent;
    FOnSelfChangeEvent: TMySelfChangeEvent;

    procedure GlyphChanged(Sender: TObject);
    procedure UpdateExclusive;
    function GetGlyph: TBitmap;
    procedure SetGlyph(Value: TBitmap);
    function GetNumGlyphs: TautoNumGlyphs;
    procedure SetNumGlyphs(Value: TautoNumGlyphs);
    procedure SetDown(Value: Boolean);
    procedure SetFlat(Value: Boolean);
    procedure SetAllowAllUp(Value: Boolean);
    procedure SetGroupIndex(Value: Integer);
    procedure SetLayout(Value: TautoButtonLayout);
    procedure SetSpacing(Value: Integer);
    procedure SetTransparent(Value: Boolean);
    procedure SetMargin(Value: Integer);
    procedure UpdateTracking;
    procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure SetInColor(clr:TColor);
    procedure SetLeaveColor(clr:TColor);
  protected
    FState: TautoButtonState;

    procedure selfDblClick; dynamic;
    procedure selfEnter; dynamic;
    procedure selfExit; dynamic;
    procedure selfChange; dynamic;
    
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    function GetPalette: HPALETTE; override;
    procedure Loaded; 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 Paint; override;
    property MouseInControl: Boolean read FMouseInControl;
    procedure SetCurtext(Value: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
  published
    property InColor:TColor read FInColor write SetInColor;
    property LeaveColor:TColor read FLeaveColor write SetLeaveColor;
    property Action;
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
    property Down: Boolean read FDown write SetDown default False;
    property Caption;
    property Enabled;
    property Flat: Boolean read FFlat write SetFlat default False;
    property Font;
    property Color;
    property Glyph: TBitmap read GetGlyph write SetGlyph;
    property Layout: TautoButtonLayout read FLayout write SetLayout default baGlyphLeft;
    property Margin: Integer read FMargin write SetMargin default -1;
    property NumGlyphs: TautoNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;
    property ParentFont;
    property ParentShowHint;
    property ParentBiDiMode;
    property PopupMenu;
    property ShowHint;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property Transparent: Boolean read FTransparent write SetTransparent default True;
    property BordFlat : boolean read FBordFlat write FBordFlat;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Curtext: string
      read FCurtext
      write SetCurtext
      stored true;

    property OnSelfDblClick: TMySelfDblClickEvent
      read FOnSelfDblClickEvent
      write FOnSelfDblClickEvent;

    property OnSelfEnter: TMySelfEnterEvent
      read FOnSelfEnterEvent
      write FOnSelfEnterEvent;

    property OnSelfExit: TMySelfExitEvent
      read FOnSelfExitEvent
      write FOnSelfExitEvent;

    property OnSelfChange: TMySelfChangeEvent
      read FOnSelfChangeEvent
      write FOnSelfChangeEvent;
  end;

{TMyAutoBitBtn}
  TMyAutoBitBtn = class(TButton)
  private
    FCanvas: TCanvas;
    FGlyph: Pointer;
    FStyle: TautoButtonStyle;
    FKind: TMyAutoBitBtnKind;
    FLayout: TautoButtonLayout;
    FSpacing: Integer;
    FMargin: Integer;
    IsFocused,FGetFocus: Boolean;
    FModifiedGlyph: Boolean;
    FCurtext:string;

    FOnSelfDblClickEvent: TMySelfDblClickEvent;
    FOnSelfEnterEvent: TMySelfEnterEvent;
    FOnSelfExitEvent: TMySelfExitEvent;
    FOnSelfChangeEvent: TMySelfChangeEvent;
    
    procedure DrawItem(const DrawItemStruct: TDrawItemStruct);
    procedure SetGlyph(Value: TBitmap);
    function GetGlyph: TBitmap;
    function GetNumGlyphs: TautoNumGlyphs;
    procedure SetNumGlyphs(Value: TautoNumGlyphs);
    procedure GlyphChanged(Sender: TObject);
    function IsCustom: Boolean;
    function IsCustomCaption: Boolean;
    procedure SetStyle(Value: TautoButtonStyle);
    procedure SetKind(Value: TMyAutoBitBtnKind);
    function GetKind: TMyAutoBitBtnKind;
    procedure SetLayout(Value: TautoButtonLayout);
    procedure SetSpacing(Value: Integer);
    procedure SetMargin(Value: Integer);
    procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
      message WM_LBUTTONDBLCLK;
  protected
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    procedure CreateHandle; override;
    procedure CreateParams(var Params: TCreateParams); override;
    function GetPalette: HPALETTE; override;
    procedure SetButtonStyle(ADefault: Boolean); override;
    procedure SetCurtext(Value: string);

    procedure selfDblClick; dynamic;
    procedure selfEnter; dynamic;
    procedure selfExit; dynamic;
    procedure selfChange; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
  published
    property Action;
    property Anchors;
    property BiDiMode;
    property Cancel stored IsCustom;
    property Caption stored IsCustomCaption;
    property Constraints;
    property Default stored IsCustom;
    property Enabled;
    property Glyph: TBitmap read GetGlyph write SetGlyph stored IsCustom;
    property Kind: TMyAutoBitBtnKind read GetKind write SetKind default bCustom;
    property Layout: TautoButtonLayout read FLayout write SetLayout default baGlyphLeft;
    property Margin: Integer read FMargin write SetMargin default -1;
    property ModalResult stored IsCustom;
    property NumGlyphs: TautoNumGlyphs read GetNumGlyphs write SetNumGlyphs stored IsCustom default 1;
    property ParentShowHint;
    property ParentBiDiMode;
    property ShowHint;
    property Style: TautoButtonStyle read FStyle write SetStyle default baWinXP;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property Curtext: string
      read FCurtext
      write SetCurtext
      stored true;

    property OnSelfDblClick: TMySelfDblClickEvent
      read FOnSelfDblClickEvent
      write FOnSelfDblClickEvent;

    property OnSelfEnter: TMySelfEnterEvent
      read FOnSelfEnterEvent
      write FOnSelfEnterEvent;

    property OnSelfExit: TMySelfExitEvent
      read FOnSelfExitEvent
      write FOnSelfExitEvent;

    property OnSelfChange: TMySelfChangeEvent
      read FOnSelfChangeEvent
      write FOnSelfChangeEvent;
      
    property TabOrder;
    property TabStop;
    property Visible;
    property OnEnter;
    property OnExit;
  end;

implementation

uses
  SysUtils,
  ActnList,
  ImgList,
  mySourcestring;

var
  osvi : TOSVersionInfo;

var
  BitBtnResNames: array[TMyAutoBitBtnKind] of PChar = (
    nil, 'BB_OK', 'BB_CANCEL', 'BB_HELP', 'BB_YES', 'BB_NO', 'BB_CLOSE',
    'BB_ABORT', 'BB_RETRY', 'BB_IGNORE', 'BB_ALL','BB_Add','BB_Del','BB_Modify',
    'BB_Save','BB_Find','BB_Print','BB_Preview','BB_Prev','BB_Next','BB_Prev_',
    'BB_Next_','BB_First','BB_Last','BB_PrintSetup','BB_DesignTimer','BB_SELF',
    'BB_IMAGELOAD','BB_IMAGECLEAR','BB_IMAGESAVE','BB_CLEAR','BB_SELECTALL',
    'BB_ADDSUB','BB_IMAGECOPY','BB_IMAGEPASTE','BB_RUNTEST','BB_UPDATE',
    'BB_REFRESHONE','BB_REFRESHALL','BB_CONTINUS','BB_SCrop','BB_Sort','BB_Wizard',
    'BB_DeleteAll','BB_RECYE','BB_SpecReportDesign','BB_SpecReportClear','BB_Vector',
    'BB_Edit','BB_Insert','BB_Reset','BB_Updating','BB_Excel','BB_WORD','BB_PDF',
    'BB_RECORDCOPY', 'BB_RECORDFIRS', 'BB_RECORDPREV', 'BB_RECORDNEXT', 'BB_RECORDLAST');

  BitBtnCaptions950: array[TMyAutoBitBtnKind] of string = (
    '', SautoOKButton, SautoCancelButton, SautoHelpButton, SautoYesButton, SautoNoButton,
    SautoCloseButton, SautoAbortButton, SautoRetryButton, SautoIgnoreButton,
    SautoAllButton,SautoAddButton,SautoDelButton,SautoModifyButton,SautoSaveButton,SautoFindButton,
    SautoPrintButton,SautoPreviewButton,SautoPrevButton,SautoNextButton,SautoPrev_Button,
    SautoNext_Button,SautoFirstButton,SautoLastButton,SautoPrintSetupButton,
    SautoDesignTimerButton,SautoSelfButton,SautoImageLoadButton,SautoImageClearButton,SautoImageSaveButton,
    SautoClearButton,SautoSelectAllButton,SautoAddSubButton,SautoImageCopyButton,
    SautoImagePasteButton,SautoRunTestButton,SautoUpdateButton,
    SautoRefreshOneButton,SautoRefreshAllButton,SautoContinusButton,SautoScropButton,SautoSortButton,SautoWizardButton,
    SautoDeleteAllButton,SautoRecyeButton,SautoSpecReportDesign,SautoSpecReportClear,SautoVector,
    SautoEdit,SautoInsert,SautoReset,SautoUpdating,SautoExcel,SautoWord,SautoPDF,
    SautoRecordCopy,SautoRecordFirs,SautoRecordPrev,SautoRecordNext,SautoRecordLast);

  BitBtnModalResults: array[TMyAutoBitBtnKind] of TModalResult = (
    0, mrOk, mrCancel, 0, mrYes, mrNo, 0, mrAbort, mrRetry, mrIgnore,
    mrAll,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,0,0,0);
var
  BitBtnGlyphs: array[TMyAutoBitBtnKind] of TBitmap;

function GetBitBtnGlyph(Kind: TMyAutoBitBtnKind): TBitmap;
begin
  if BitBtnGlyphs[Kind] = nil then
  begin
    BitBtnGlyphs[Kind] := TBitmap.Create;
    BitBtnGlyphs[Kind].LoadFromResourceName(HInstance, BitBtnResNames[Kind]);
  end;
  Result := BitBtnGlyphs[Kind];
end;

function GetMenuWidth( Control: TControl; DropDownMenu: TPopupMenu ): Integer;
var
  Canvas: TControlCanvas;
  W, I: Integer;
begin
  Canvas := TControlCanvas.Create;
  Canvas.Control := Control;
  try
    Canvas.Font := Screen.MenuFont;
    Result := 0;
    for I := 0 to DropDownMenu.Items.Count - 1 do
    begin
      W := Canvas.TextWidth( DropDownMenu.Items[ I ].Caption );
      if W > Result then
        Result := W;
    end;
    Result := Result + 56;
  finally
    Canvas.Free;
  end;
end;
    
type
  TGlyphList = class(TImageList)
  private
    Used: TBits;
    FCount: Integer;
    function AllocateIndex: Integer;
  public
    constructor CreateSize(AWidth, AHeight: Integer);
    destructor Destroy; override;
    function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
    procedure Delete(Index: Integer);
    property Count: Integer read FCount;
  end;
    
  TGlyphCache = class
  private
    GlyphLists: TList;
  public
    constructor Create;
    destructor Destroy; override;
    function GetList(AWidth, AHeight: Integer): TGlyphList;
    procedure ReturnList(List: TGlyphList);
    function Empty: Boolean;
  end;
    
  TButtonGlyph = class
  private
    FOriginal: TBitmap;
    FGlyphList: TGlyphList;
    FIndexs: array[TautoButtonState] of Integer;
    FTransparentColor: TColor;
    FNumGlyphs: TautoNumGlyphs;
    FOnChange: TNotifyEvent;
    procedure GlyphChanged(Sender: TObject);
    procedure SetGlyph(Value: TBitmap);
    procedure SetNumGlyphs(Value: TautoNumGlyphs);
    procedure Invalidate;
    function CreateButtonGlyph(State: TautoButtonState): Integer;
    procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
      State: TautoButtonState; Transparent: Boolean);
    procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
      TextBounds: TRect; State: TautoButtonState; BiDiFlags: Longint);
    procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
      const Offset: TPoint; const Caption: string; Layout: TautoButtonLayout;
      Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
      BiDiFlags: Longint);
  public
    constructor Create;
    destructor Destroy; override;
    { return the text rectangle }
    function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
      const Caption: string; Layout: TautoButtonLayout; Margin, Spacing: Integer;
      State: TautoButtonState; Transparent: Boolean; BiDiFlags: Longint): TRect;
    property Glyph: TBitmap read FOriginal write SetGlyph;
    property NumGlyphs: TautoNumGlyphs read FNumGlyphs write SetNumGlyphs;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;
    
{ TGlyphList }
    
constructor TGlyphList.CreateSize(AWidth, AHeight: Integer);
begin
  inherited CreateSize(AWidth, AHeight);
  Used := TBits.Create;
end;
    
destructor TGlyphList.Destroy;
begin
  Used.Free;
  inherited Destroy;
end;
    
function TGlyphList.AllocateIndex: Integer;
begin
  Result := Used.OpenBit;
  if Result >= Used.Size then
  begin
    Result := inherited Add(nil, nil);
    Used.Size := Result + 1;
  end;
  Used[Result] := True;
end;
    
function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
begin
  Result := AllocateIndex;
  ReplaceMasked(Result, Image, MaskColor);
  Inc(FCount);
end;
    
procedure TGlyphList.Delete(Index: Integer);
begin
  if Used[Index] then
  begin
    Dec(FCount);
    Used[Index] := False;
  end;
end;
    
{ TGlyphCache }
    
constructor TGlyphCache.Create;
begin
  inherited Create;
  GlyphLists := TList.Create;
end;
    
destructor TGlyphCache.Destroy;
begin
  GlyphLists.Free;
  inherited Destroy;
end;
    
function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
var
  I: Integer;
begin
  for I := GlyphLists.Count - 1 downto 0 do
  begin
    Result := GlyphLists[I];
    with Result do
      if (AWidth = Width) and (AHeight = Height) then Exit;
  end;
  Result := TGlyphList.CreateSize(AWidth, AHeight);
  GlyphLists.Add(Result);
end;
    
procedure TGlyphCache.ReturnList(List: TGlyphList);
begin
  if List = nil then Exit;
  if List.Count = 0 then
  begin