ＢｉｔＢｔｎＥｘ　(ビットボタンの拡張ボタン)

　TBitBtnを元に、カラーボタン、楕円ボタンを追加してみました。

楕円ボタンコンポーネントは、TGraphicControlを継承している為、タブストップが有りませんでしたが、BitBtnを元に、楕円ボタンを追加しているので、ここでの楕円ボタンには、タブストップ゛があります。
TBitBtnは、TCustomButtonを継承しています。

(注　Delphi XE3 の場合について記述しています。)

１．まず最初にRAD Studio　の　sourceホルダーの中の　Vcl.Buttons.pas　から、Bitbtnに関するものだけ、まず抜き出します。

Vcl.Buttons.pasには、TButton、TSpeedBtn、TBitbtnの三種類のボタンが入っているので、TBitbtnだけにする簡単な方法を記します。
１－ １．新規作成で、VCLアプリケーションを選択します。
１－ ２．BitBtnを、Formに３個程度用意します。
１－ ３．新しいホルダーを用意して、その中にプロジェクト、名前をつけて保存します。ユニットも同じホルダーに保存します。
１－ ４．Vcl.Buttons.pasのコピーをプロジェクトと同じホルダーにコピーして、Buttons.pasにします。
１－ ５．uses　のVcl.ButtonsをButtonsに変更します。
１－ ６．Buttons.pasを開きます。　(プロジェクトを開いたまま、Buttons.pasも開きます、Buttons.pasのタブが追加されます。)
１－ ７．Form上のBitBtnの１つにに、画像を追加します。又、他のBitBtnの１つのKindプロパティで、bkCustome以外のものを指定します。
１－ ８．Buttons.pasのタブをクリックして、Buttons.pasを表示します。
１－ ９．デバッグモードで、ビルドすると、開いているButtons.pasに、デバッグ用ブレークアイコンが付加されるので、使用されていないルーチンを消去します。

　もし、間違って必要な部分を消去してしまった場合は、直ぐに元へ戻しましょう。
　少し消去しては、ビルドをしながら、消していくと問題なくBitBtnの必要な部分だけを残すことが出来、これで、準備完了です。
　これは、他のコンポーネントにも応用が出来ます。

２．TBitBtnEXパッケージ作成

２－ １．BitBtnの部分だけになったButtons.pasの中の"TBitBtn"を"TBitBtnEX"に、検索の置換を使用して全て置き換えます。
２－ ２．名前を付けて保存で、新しいホルダーを作成し、ホルダー名を"BitbtnEx"、"BitbtnExPak"等の分かり易いホルダー名にしてその中に　"BitbtnEx.pas"のファイル名で保存し閉じます。
２－ ３．新規作成でパッケージを作成、プロジェクトに追加で、先ほど保存した"BitbtnEx.pas"を追加します。
２－ ４．プロジェクトに名前を付けて保存で、"TBitBtnEx.dproj"の名前で先ほど作成したホルダーに保存します。
２－ ５．リソースファイルの指定場所を変更します。(プロジェクトマネージャーの"TBitBtnEx..bpl"を選択、マウス右ボタン、ソースの表示を選択で、dpkファイルをひらきます。)
        BitbtnEx.pasの中の、"{$R Buttons.res}"を探し出し、package TBitBtnEx;へ移動します。

(注) ホルダーの場所は、"C:\Users\Public\Documents\RAD Studio\10.0\MyVcl\BitbtnEx" の様にします。

package TBitBtnEx;

{$R *.res}
{$R Buttons.res}      <- 此処へ移動
{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users}
{$ALIGN 8}
{$ASSERTIONS ON}

２－ ６．BitbtnEx.pas　170行目近辺の　"BitBtnCaptions: array[TBitBtnEXKind] of Pointer = (
          nil, @SOKButton, @SCancelButton, @SHelpButton, ．．．．
        のPointerが取得できなくなりますので、PCharにして直接 指定します。

  BitBtnExCaptions: array[TBitBtnEXKind] of PChar = ( 　　　　　　　　　　　// pointer　から PCharに変更
    nil, 'OK', 'キャンセル', 'ヘルプ(&H)', 'はい(&Y)', 'いいえ(&N)',
    '閉じる(&C)', '中止', '再試行(&R)', '無視(&I)',
    'すべて(&A)');

２－ ７．コンポーネントの登録指定を追加します。

procedure Register;          <- 　追加

implementation

uses
Vcl.Consts, Vcl.ActnList, Winapi.UxTheme, Winapi.DwmApi,
System.Math;

// コンポーネントの登録指定
procedure Register;　　　　　<- 　追加
begin
  RegisterComponents('MyVCL', [TBitBtnEX]);
end;

２－ ８．BitBtnExホルダーにツール、オプションでライブラリのパスを追加します。

以上で、準備完了です、とりあえずインストールしてみましょう。

警告が表示されますが、間違いがなければ、追加されたことのメッセージが表示されます。

"[dcc32 警告] BitbtnEx.pas(1): W1025 class constructor : この仕様はサポートされていません"　の表示が気になる場合は、プロジェクトのオプション　Delphiコンパイラ　-C/C++ C/C++出力ファイルの生成　を　DCUのみ生成　にします。
"[dcc32 警告] BitbtnEx.pas(32): W1000 シンボル 'TImageIndex' を使用することは推奨されていません : 'Use System.UITypes.TImageIndex'" の表示も気になる場合は、プロジェクトのオプション　Delphiコンパイラ　ヒントと警告　使用を推奨されていないシンボルを　False にすれば表示されなくなります。


２－ ９．TBitBtbEx.bplを保存閉じます。

３．TBitBtnExの確認

３－ １．新規ＶＣＬフォームアプリケーションで新しいプロジェクトの起動をします。
３－ ２．ツールパレットの「MyVcl」　TBitBtnExをフォームに貼り付けます。
３－ ３．BitBtnEx1プロパティの Kind 変更　Fontの色変更等をテストしてみて下さい。
　　BitBtnと全く同じボタンとなります。
　　BitBtnから未だ何も変更していないので当然です。

４．拡張部分の追加変更

　いよいよ、拡張部分の追加です。

４－ １．最初に、BitBtnExのボタンの種類プロパティKindで指定して表示される、画像の変更が出来る様にします。

　プロパティKindで表示している画像は、Buttons.resファイルの中に設定されているので、"C:\Program Files\Embarcadero\RAD Studio\10.0\lib\win32\release"ホルダーの中に入っているButtons.resファイルをBitBtnExフォルダーにコピーします。
コピーしたらファイルの名前を、BitBtnEx.resに変更します。
TBitBtnEx.dprojを開き、TBitBtnEx.bpl　のソースの　{$R 'Buttons.res'}　を　{$R 'BitbtnEx.res'}に変更します。

resファイルの画像の編集には、XN Resource Editor 3.0.0.1 [ja] が便利です、ダウンロードして利用しましょう。

リソースエディターは、.ツールパレットに表示されるアイコン用 dcr ファイルの編集にも使用出来ます。

４－ ２．ツールパレットに表示されるアイコンの追加

　dcr ファイルを作る必要があります。
XN Resource Editorを起動　新規作成を実行　リソースの追加で　Bitmapを選択します。

上図の内容が表示されたら、Bitmapの下の 1 を　TBITBTNEX　に変更します。
更に、Width 及び　Height を 24 に　pixcelFormat を4ビットに設定し、アイコン用画像の編集をします。
編集が終了したら、'BitBtnEx.dcr' のファイル名で、BitBtnExフォルダーへ保存終了します。
TBitBtnEx.dprojを開き、TBitBtnEx.bpl　のソースに　{$R 'BitBtnEx.dcr'}　を追加します。

package TBitBtnEx;

{$R *.res}
{$R 'BitbtnEx.res'}
{$R 'BitbtnEx.dcr'}        <-- 追加

TBitBtn.bpl のアンインストール実行後、再インストールします、これで、新しいアイコンが表示されます。
dcrファイルの作成は"Resource Editor"を使用しなくても作成出来ます、その方法はインターネットで検索してください。
又は、コンポーネント用アイコンの作り方 (2005 以降)を参照してください。

４－ ３．プロパティの追加、変更、新しいボタン描画部分の追加変更
    BitBtnEXに必要な新しい property を追加、又は、変更します。

    property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth; // BevelWidth設定用追加
    property Color: TColor read FColor write SetColor;                               // OvalButtonの色設定用追加

４－ ３－１．Type TButtonStyleの変更
  　TButtonStyle = (bsAutoDetect, bsWin31, bsNew);  となっていますが、BitBtnでは、Style を指定しても、無効で何も変りません。
　　function DrawButtonFace(Canvas: TCanvas; const Client: TRect;BevelWidth: Integer; Style: TButtonStyle; IsRounded, IsDown,IsFocused: Boolean): TRect;
　で使用されいのてすが、どこからも呼び出されることはありません。
　　Delphi 7 で既に使用されなくなっていましたので、何時ごろから使用されなくなったかは不明です。
　それで、これを
　TButtonStyle = (bsStandard, bsOvalDraw, BsColorDRaw);に変更して、楕円ボタン、カラーボタンの指定が出来る様にします。

４－ ３－２．本ホームページでダウンロード出来る、楕円ボタンコンポーネントのソースファイルから、楕円ボタン描画部分を追加します。
    function HLS2RGB(const HLS: TColorVector): TColorVector; // 影部色設定追加
    function RGB2HLS(const RGB: TColorVector): TColorVector; // 影部色色係数追加
    procedure Get3DColors(FColor: TColor; var HighLightColor, ShadowColor: TColor; HLFactor, ShFactor: single);   // BevelColorの明暗色設定 追加
    procedure PaintBorder(FState: Integer);                  // Bevel部描画追加

４－ ３－３．procedure TBitBtnEX.DrawItem に、FStyle の　bsOvalDraw, BsColorDRaw　を判別して、ボタンの描画するルーチンを追加します。
  if FStyle = BsOvalDRaw then begin // OvalButton指定時の描画部追加　テーマ、非テーマにかかわらず同じボタンが描画されます。
    FCanvas.Pen.Style := psSolid;
           ・
           ・                                      此処には楕円形ボタンの作図が入ります。
           ・
    FCanvas.Ellipse(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1); // 一番外側のフレーム枠描画
  end
// **************************************************************************
  else begin
    if ThemeControl(Self) then　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　テーマの場合
    begin
           ・
           ・
      LStyle.DrawElement(DrawItemStruct.hDC, Details, DrawItemStruct.rcItem);　　　　ボタンの基本部が描画されます。
// **************************************
      if FStyle = BsColorDRaw then begin // BsColorDRaw追加 buttonの中を指定色で再描画 追加　　
        R := ClientRect;
           ・　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　 　　　　　　ここでボタンの内側を新しく追加した指定色で塗りつぶします。
           ・　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　clBtnFaceで塗りつぶされた場所を指定色で再描画します。
      end;
// **************************************
      LStyle.GetElementContentRect(FCanvas.Handle, Details, DrawItemStruct.rcItem, R);
           ・
           ・   
   end
    else　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　クラシック表示の場合
    begin
      Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
           ・
           ・
        if FStyle = BsColorDRaw then // BsColorDRaw追加 buttonの中を指定色で再描画 追加　　　　　カラーボタンだったら指定色
          FCanvas.Brush.Color := FColor
        else
          FCanvas.Brush.Color := clBtnFace;
           ・
           ・
        if FStyle = BsColorDRaw then begin // BsColorDRaw追加 buttonの中を指定色で再描画 追加　カラーボタンだったら指定色
          FCanvas.Pen.Style := PsClear;
          FCanvas.Brush.Color := FColor;
          FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
        end;
           ・
           ・
      TButtonGlyph(FGlyph).Draw(FCanvas, R, Point(0,0), Caption, FLayout, FMargin,
        FSpacing, State, True, DrawTextBiDiModeFlags(0) or WordBreakFlag[WordWrap]); // TransparentをTrueに設定　Ｔｒｕｅにすることで、画像のバックグラウンド色をボタンの色にします。
           ・
           ・
  FCanvas.Handle := 0;
end;

４－ ３－４．マウスに応答する範囲の設定の追加
  楕円ボタンの場合、マウスカーソルに応答する範囲も楕円形に変更します。
　ボタン生成時                procedure CreateWnd; override;
　ボタンサイズ変更時　　　procedure Resize; override;

procedure TBitBtnEX.CreateWnd; // Create時SetRegionの追加
begin
  inherited CreateWnd;
  SetRegion;
end;

procedure TBitBtnEX.Resize; // ResizeのSetRegionの追加
begin
  inherited Resize;
  SetRegion;
//  if assigned(FOnResize) then // BitBtnにOnResizeなし
//  FOnResize(Self);
end;

procedure TBitBtnEX.SetRegion; // 楕円形 又は 四角形のRegionの設定追加
var region: HRGN;
begin
  if FStyle = BsOvalDRaw then begin // 楕円形の場合 Regionの設定変更
    Region := CreateEllipticRgn(0, 0 , width + 1, height + 1); // 楕円形の指定;
//  else // 四角形は設定されているので不要
//    Region := CreateRoundRectRgn (0, 0, Width + 1, Height + 1, 2, 2); // 四角形の指定
    SetWindowRgn(Handle, Region, True);
    DeleteObject(Region);
  end;
end;

その他、細かい部分の修正は、BitBtnEx.pas のリストを参照して下さい。

５．TBitBtnExの実行結果

　左側が通常のBitBtnで、右側がBitBtnExの実行結果です。

実行画面は、Ｗｉｎｄｏｗｓ７の場合です。

BitBtnExで、BitBtnと同じ表示は全て可能で、楕円とカラーボタンが拡張として追加されています。



　楕円ボタンのマウスカーソルに対する、応答、状態の表示描画です。

Enabled イネーブル状態

MouseEnter マウスカーソルが、ボタンの上に来たら、Bevelの表示
クラシック表示では、MouseEnterモードはありません。

Down マウス左ボタンを押した状態

Focused フォーカスがある状態で、フォーカス点線表示

Disable デスエブル表示、文字グレイ、ディスエブル画像

　古い、テーマモードの無いクラシック画面表示の確認をする必要がある場合、Ｗｉｎｄｏｗｓ８以降では、クラシックモードが無いので、互換モードを使用して確認を行います。
互換モードを　Ｗｉｎｄｏｗｓ　Ｍｅにして、８ビットカラー表示にすれば、クラシック表示（非テーマ）の確認ができます。
互換モードをＷｉｎｄｏｗｓ７にしても、ボタンのデザインはＷｉｎｄｏｗｓ７にはならないようです。
新しいソフトを開発する場合は、基本的にはＷｉｎｄｏｗｓＸＰ以前のＷｉｎｄｏｗｓを使用することは無いので、そろそろクラシック表示は不要なのかもしれません。

互換モード　Ｗｉｎｄｏｗｓ　Ｍｅ　８ビットカラー表示

下図左側がＷｉｎｄｏｗｓＭｅ互換モードで、右側がＷｉｎｄｏｗｓ８．１の通常モードです。
楕円のボタンは、Ｗｉｎｄｏｗｓテーマと無関係なので、ＯＳのバージョンには左右されません。


function DrawButtonFaceを利用して、参考表示すると、Win3.1タイプは次の様になります。
下図左側のボタンが、昔懐かしいWin3.1のボタンです。(べベル幅２に設定)

BitbtnEx.pas ソースリスト

 unit BitbtnEx;

interface

uses Winapi.Windows, Winapi.Messages, System.Classes, System.Types, VCL.Controls, Vcl.Forms, Vcl.Graphics,
  Vcl.StdCtrls, Vcl.ExtCtrls, Winapi.CommCtrl, Vcl.ImgList,
  Vcl.Themes, System.Generics.Collections, SysUtils;

type
  TButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
  TButtonState = (bsUp, bsDisabled, bsDown, bsExclusive);
  TButtonStyle = (bsStandard, bsOvalDraw, BsColorDRaw); // ButtonStyleのbsOvalDraw,BsColorDRaw追加変更
  TNumGlyphs = 1..4;

  TColorVector = record          // bsOvalButtonの色設定用追加
    case Integer of
      0: (Coord: array[0..2] of Double);
      1: (R, G, B: Double);
      2: (H, L, S: Double);
  end;

  EColorConv = class(Exception); // 色変換エラー用

  TBitBtnEX = class;             // Tbitbtn -> TBitBtnEX 全て変更

  TBitBtnEXActionLink = class(TControlActionLink)
  protected
    FClient: TBitBtnEX;
    FImageIndex: Integer;
    procedure AssignClient(AClient: TObject); override;
    function IsImageIndexLinked: Boolean; override;
    function IsGlyphLinked(Index: TImageIndex): Boolean;
    procedure SetImageIndex(Value: Integer); override;
  public
    constructor Create(AClient: TObject); override;
  end;

  TBitBtnEXKind = (bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose,
    bkAbort, bkRetry, bkIgnore, bkAll);

  TBitBtnEX = class(TCustomButton)
  strict private
    class constructor Create;
    class destructor Destroy;
  private
    FBevelWidth: TBevelWidth; // 縁枠の幅追加
    FColor,
    FColorHighlight,
    FColorShadow: TColor;     // OvalButtonの色追加
    FCanvas: TCanvas;
    FGlyph: TObject;
    FStyle: TButtonStyle;
    FKind: TBitBtnEXKind;
    FLayout: TButtonLayout;
    FSpacing: Integer;
    FMargin: Integer;
    IsFocused: Boolean;
    FModifiedGlyph: Boolean;
    FMouseInControl: Boolean;
//    FOnResize : TNotifyEvent;     // BitBtnにOnResizeなし
    function HLS2RGB(const HLS: TColorVector): TColorVector; // 影部色設定追加
    function RGB2HLS(const RGB: TColorVector): TColorVector; // 影部色色係数追加
    procedure Get3DColors(FaceColor: TColor; var HighLightColor, ShadowColor: TColor; HLFactor, ShFactor: single); // BevelColorの明暗色設定 追加
    procedure PaintBorder(FState: Integer);                  // Bevel部描画追加
    procedure DrawItem(const DrawItemStruct: TDrawItemStruct);
    procedure SetGlyph(Value: TBitmap);
    function GetGlyph: TBitmap;
    function GetNumGlyphs: TNumGlyphs;
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure GlyphChanged(Sender: TObject);
    procedure InternalCopyImage(Image: TBitmap; ImageList: TCustomImageList; Index: Integer);
    function IsCustom: Boolean;
    function IsCustomCaption: Boolean;
    procedure SetStyle(Value: TButtonStyle);
    procedure SetKind(Value: TBitBtnEXKind);
    function GetKind: TBitBtnEXKind;
    procedure SetLayout(Value: TButtonLayout);
    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;
    procedure SetRegion;                            // Oval Region設定追加
  protected
    procedure CreateWnd; override;                 // Create時Oval Region設定追加
    procedure SetBevelWidth(newValue: TBevelWidth); // OvalButtonのBevelWidth設定追加
    procedure SetColor(newColor: TColor);           // OvalButtonの色設定追加
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
    procedure CreateHandle; override;
    procedure CreateParams(var Params: TCreateParams); override;
    function GetActionLinkClass: TControlActionLinkClass; override;
    function GetPalette: HPALETTE; override;
    procedure SetButtonStyle(ADefault: Boolean); override;
    procedure UpdateStyleElements; override;
    procedure Resize; override;                   // Resize時のOval Region再設定用に追加
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
  published
    property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth; // BevelWidth設定用追加
    property Color: TColor read FColor write SetColor;                     // OvalButtonの色設定用追加
    property Action;
    property Align;
    property Anchors;
    property BiDiMode;
    property Cancel stored IsCustom;
    property Caption stored IsCustomCaption;
    property Constraints;
    property Default stored IsCustom;
    property DoubleBuffered default True;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property Glyph: TBitmap read GetGlyph write SetGlyph stored IsCustom;
    property Kind: TBitBtnEXKind 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 stored IsCustom;
    property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;
    property ParentBiDiMode;
    property ParentDoubleBuffered default False;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Style: TButtonStyle read FStyle write SetStyle default bsStandard; //スタイルの設定変更
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property TabOrder;
    property TabStop;
    property Visible;
    property WordWrap;
    property StyleElements;
    property OnClick;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
//    property OnResize:TNotifyEvent read FOnResize write FOnResize;
  end;


  TBitBtnEXStyleHook = class(TButtonStyleHook)
  strict protected
    procedure DrawButton(ACanvas: TCanvas; AMouseInControl: Boolean); override;
  end;

procedure Register;

implementation

uses
  Vcl.Consts, Vcl.ActnList, Winapi.UxTheme, Winapi.DwmApi,
  System.Math;

// コンポーネントの登録
procedure Register;
begin
  RegisterComponents('MyVCL', [TBitBtnEX]);
end;

//{$R BitbtnEx.res} dpkファイルに移行

{ TBitBtnEX data }
var
  BitBtnExResNames: array[TBitBtnEXKind] of PChar = (
    nil, 'BBOK', 'BBCANCEL', 'BBHELP', 'BBYES', 'BBNO', 'BBCLOSE',
    'BBABORT', 'BBRETRY', 'BBIGNORE', 'BBALL');
  BitBtnExCaptions: array[TBitBtnEXKind] of PChar = (                  // pointer　から PCharに変更
    nil, 'OK', 'キャンセル', 'ヘルプ(&H)', 'はい(&Y)', 'いいえ(&N)',
    '閉じる(&C)', '中止', '再試行(&R)', '無視(&I)',
    'すべて(&A)');
  BitBtnExModalResults: array[TBitBtnEXKind] of TModalResult = (
    0, mrOk, mrCancel, 0, mrYes, mrNo, 0, mrAbort, mrRetry, mrIgnore,
    mrAll);

  BitBtnExGlyphs: array[TBitBtnEXKind] of TBitmap;

const
  FHLContrast = 5; // Bevel明部輝度係数　追加
  FShContrast = 4; // Bevel影部輝度係数 追加

function GeTBitBtnEXGlyph(Kind: TBitBtnEXKind): TBitmap;
begin
  if BitBtnExGlyphs[Kind] = nil then
  begin
    BitBtnExGlyphs[Kind] := TBitmap.Create;
    BitBtnExGlyphs[Kind].LoadFromResourceName(HInstance, BitBtnExResNames[Kind]);
  end;
  Result := BitBtnExGlyphs[Kind];
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[TButtonState] of Integer;
    FTransparentColor: TColor;
    FNumGlyphs: TNumGlyphs;
    FPaintOnGlass: Boolean;
    FThemeDetails: TThemedElementDetails;
    FThemesEnabled: Boolean;
    FOnChange: TNotifyEvent;
    FThemeTextColor: Boolean;
    procedure GlyphChanged(Sender: TObject);
    procedure SetGlyph(Value: TBitmap);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure Invalidate;
    function CreateButtonGlyph(State: TButtonState): Integer;
    procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
      State: TButtonState; Transparent: Boolean);
    procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
      TextBounds: TRect; State: TButtonState; Flags: Longint);
    procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
      const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
      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: TButtonLayout; Margin, Spacing: Integer;
      State: TButtonState; Transparent: Boolean; BiDiFlags: Longint): TRect;
    property Glyph: TBitmap read FOriginal write SetGlyph;
    property NumGlyphs: TNumGlyphs 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 := TGlyphList(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
    GlyphLists.Remove(List);
    List.Free;
  end;
end;

function TGlyphCache.Empty: Boolean;
begin
  Result := GlyphLists.Count = 0;
end;

var
  GlyphCache: TGlyphCache = nil;
  ButtonCount: Integer = 0;

{ TButtonGlyph }

constructor TButtonGlyph.Create;
var
  I: TButtonState;
begin
  inherited Create;
  FOriginal := TBitmap.Create;
  FOriginal.OnChange := GlyphChanged;
  FTransparentColor := clOlive;
  FNumGlyphs := 1;
  FPaintOnGlass := False;
  FThemesEnabled := False;
  FThemeTextColor := True;
  for I := Low(I) to High(I) do
    FIndexs[I] := -1;
  if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
end;

destructor TButtonGlyph.Destroy;
begin
  FOriginal.Free;
  Invalidate;
  if Assigned(GlyphCache) and GlyphCache.Empty then
  begin
    GlyphCache.Free;
    GlyphCache := nil;
  end;
  inherited Destroy;
end;

procedure TButtonGlyph.Invalidate;
var
  I: TButtonState;
begin
  for I := Low(I) to High(I) do
  begin
    if FIndexs[I] <> -1 then FGlyphList.Delete(FIndexs[I]);
    FIndexs[I] := -1;
  end;
  GlyphCache.ReturnList(FGlyphList);
  FGlyphList := nil;
end;

procedure TButtonGlyph.GlyphChanged(Sender: TObject);
begin
  if Sender = FOriginal then
  begin
    FTransparentColor := FOriginal.TransparentColor;
    Invalidate;
    if Assigned(FOnChange) then FOnChange(Self);
  end;
end;

procedure TButtonGlyph.SetGlyph(Value: TBitmap);
var
  Glyphs: Integer;
begin
  Invalidate;
  FOriginal.Assign(Value);
  if (Value <> nil) and (Value.Height > 0) then
  begin
    FTransparentColor := Value.TransparentColor;
    if Value.Width mod Value.Height = 0 then
    begin
      Glyphs := Value.Width div Value.Height;
      if Glyphs > 4 then Glyphs := 1;
      SetNumGlyphs(Glyphs);
    end;
  end;
end;

procedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);
begin
  if (Value <> FNumGlyphs) and (Value > 0) then
  begin
    Invalidate;
    FNumGlyphs := Value;
    GlyphChanged(Glyph);
  end;
end;

const
  ROP_DSPDxax = $00E20746;

function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;
var
  TmpImage, DDB, MonoBmp: TBitmap;
  IWidth, IHeight: Integer;
  IRect, ORect: TRect;
  I: TButtonState;
  DestDC: HDC;
begin
  if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
  Result := FIndexs[State];
  if Result <> -1 then Exit;
  if (FOriginal.Width or FOriginal.Height) = 0 then Exit;
  IWidth := FOriginal.Width div FNumGlyphs;
  IHeight := FOriginal.Height;
  if FGlyphList = nil then
  begin
    if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
    FGlyphList := GlyphCache.GetList(IWidth, IHeight);
  end;
  TmpImage := TBitmap.Create;
  try
    TmpImage.Width := IWidth;
    TmpImage.Height := IHeight;
    IRect := Rect(0, 0, IWidth, IHeight);
    TmpImage.Canvas.Brush.Color := clBtnFace;
    TmpImage.Palette := CopyPalette(FOriginal.Palette);
    I := State;
    if Ord(I) >= NumGlyphs then I := bsUp;
    ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
    case State of
      bsUp, bsDown,
      bsExclusive:
        begin
          TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
          if FOriginal.TransparentMode = tmFixed then
            FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor)
          else
            FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
        end;
      bsDisabled:
        begin
          MonoBmp := nil;
          DDB := nil;
          try
            MonoBmp := TBitmap.Create;
            DDB := TBitmap.Create;
            DDB.Assign(FOriginal);
            DDB.HandleType := bmDDB;
            if NumGlyphs > 1 then
            with TmpImage.Canvas do
            begin { Change white & gray to clBtnHighlight and clBtnShadow }
              CopyRect(IRect, DDB.Canvas, ORect);
              MonoBmp.Monochrome := True;
              MonoBmp.Width := IWidth;
              MonoBmp.Height := IHeight;

              { Convert white to clBtnHighlight }
              DDB.Canvas.Brush.Color := clWhite;
              MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
              Brush.Color := clBtnHighlight;
              DestDC := Handle;
              SetTextColor(DestDC, clBlack);
              SetBkColor(DestDC, clWhite);
              BitBlt(DestDC, 0, 0, IWidth, IHeight,
                MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);

              { Convert gray to clBtnShadow }
              DDB.Canvas.Brush.Color := clGray;
              MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
              Brush.Color := clBtnShadow;
              DestDC := Handle;
              SetTextColor(DestDC, clBlack);
              SetBkColor(DestDC, clWhite);
              BitBlt(DestDC, 0, 0, IWidth, IHeight,
              MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);

              { Convert transparent color to clBtnFace }
              DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);
              MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
              Brush.Color := clBtnFace;
              DestDC := Handle;
              SetTextColor(DestDC, clBlack);
              SetBkColor(DestDC, clWhite);
              BitBlt(DestDC, 0, 0, IWidth, IHeight,
              MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
            end
            else
            begin
              { Create a disabled version }
              with MonoBmp do
              begin
                Assign(FOriginal);
                HandleType := bmDDB;
                Canvas.Brush.Color := clBlack;
                Width := IWidth;
                if Monochrome then
                begin
                  Canvas.Font.Color := clWhite;
                  Monochrome := False;
                  Canvas.Brush.Color := clWhite;
                end;
                Monochrome := True;
              end;
              with TmpImage.Canvas do
              begin
                Brush.Color := clBtnFace;
                FillRect(IRect);
                Brush.Color := clBtnHighlight;
                SetTextColor(Handle, clBlack);
                SetBkColor(Handle, clWhite);
                BitBlt(Handle, 1, 1, IWidth, IHeight,
                MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
                Brush.Color := clBtnShadow;
                SetTextColor(Handle, clBlack);
                SetBkColor(Handle, clWhite);
                BitBlt(Handle, 0, 0, IWidth, IHeight,
                  MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
              end;
            end;
          finally
            DDB.Free;
            MonoBmp.Free;
          end;
          FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
        end;
    end;
  finally
    TmpImage.Free;
  end;
    Result := FIndexs[State];
    FOriginal.Dormant;
end;

procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
  State: TButtonState; Transparent: Boolean);
var
  Index: Integer;
  Details: TThemedElementDetails;
  R: TRect;
  Button: TThemedButton;
  MemDC: HDC;
  PaintBuffer: HPAINTBUFFER;
begin
  if FOriginal = nil then Exit;
  if (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit;
  Index := CreateButtonGlyph(State);
  with GlyphPos do
  begin
    if FThemesEnabled then
    begin
      R.Left := GlyphPos.X;
      R.Top := GlyphPos.Y;
      R.Right := R.Left + FOriginal.Width div FNumGlyphs;
      R.Bottom := R.Top + FOriginal.Height;
      case State of
        bsDisabled:
          Button := tbPushButtonDisabled;
        bsDown,
        bsExclusive:
          Button := tbPushButtonPressed;
      else
        // bsUp
        Button := tbPushButtonNormal;
      end;
      Details := StyleServices.GetElementDetails(Button);

      if FPaintOnGlass then
      begin
        PaintBuffer := BeginBufferedPaint(Canvas.Handle, R, BPBF_TOPDOWNDIB, nil, MemDC);
        try
          StyleServices.DrawIcon(MemDC, Details, R, FGlyphList.Handle, Index);
          BufferedPaintMakeOpaque(PaintBuffer, R);
        finally
          EndBufferedPaint(PaintBuffer, True);
        end;
      end
      else
        StyleServices.DrawIcon(Canvas.Handle, Details, R, FGlyphList.Handle, Index);
    end
    else
      if Transparent or (State = bsExclusive) then
      begin
        ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
          clNone, clNone, ILD_Transparent)
      end
      else
        ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
          ColorToRGB(clBtnFace), clNone, ILD_Normal);
  end;
end;

procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
  TextBounds: TRect; State: TButtonState; Flags: LongInt);

  procedure DoDrawText(DC: HDC; const Text: UnicodeString;
    var TextRect: TRect; TextFlags: Cardinal);
  var
    LColor: TColor;
    LFormats: TTextFormat;
  begin
    if FThemesEnabled then
    begin
      if (State = bsDisabled) or (not StyleServices.IsSystemStyle and FThemeTextColor) then
      begin
        if not StyleServices.GetElementColor(FThemeDetails, ecTextColor, LColor) or (LColor = clNone) then
          LColor := Canvas.Font.Color;
      end
      else
        LColor := Canvas.Font.Color;

      LFormats := TTextFormatFlags(TextFlags);
      if FPaintOnGlass then
        Include(LFormats, tfComposited);
      StyleServices.DrawText(DC, FThemeDetails, Text, TextRect, LFormats, LColor);
    end
    else
      Winapi.Windows.DrawText(DC, Text, Length(Text), TextRect, TextFlags);
  end;

begin
  with Canvas do
  begin
    Brush.Style := bsClear;
    if (State = bsDisabled) and not FThemesEnabled then
    begin
      OffsetRect(TextBounds, 1, 1);
      Font.Color := clBtnHighlight;
      DoDrawText(Handle, Caption, TextBounds, DT_NOCLIP or DT_CENTER or DT_VCENTER or Flags);
      OffsetRect(TextBounds, -1, -1);
      Font.Color := clBtnShadow;
      DoDrawText(Handle, Caption, TextBounds, DT_NOCLIP or DT_CENTER or DT_VCENTER or Flags);
    end
    else
      DoDrawText(Handle, Caption, TextBounds, DT_NOCLIP or DT_CENTER or DT_VCENTER or Flags);
  end;
end;

procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
  const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,
  Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
  BiDiFlags: LongInt);
var
  TextPos: TPoint;
  ClientSize, GlyphSize, TextSize: TPoint;
  TotalSize: TPoint;
begin
  if (BiDiFlags and DT_RIGHT) = DT_RIGHT then
    if Layout = blGlyphLeft then Layout := blGlyphRight
  else
    if Layout = blGlyphRight then Layout := blGlyphLeft;
  { calculate the item sizes }
  ClientSize := Point(Client.Right - Client.Left, Client.Bottom -
    Client.Top);

  if FOriginal <> nil then
    GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height) else
  GlyphSize := Point(0, 0);

  if Length(Caption) > 0 then
  begin
    TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
    DrawText(Canvas.Handle, Caption, Length(Caption), TextBounds,
    DT_CALCRECT or BiDiFlags);
    TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
    TextBounds.Top);
  end
  else
  begin
    TextBounds := Rect(0, 0, 0, 0);
    TextSize := Point(0,0);
  end;

  { If the layout has the glyph on the right or the left, then both the
    text and the glyph are centered vertically. If the glyph is on the top
    or the bottom, then both the text and the glyph are centered horizontally.}
  if Layout in [blGlyphLeft, blGlyphRight] then
  begin
    GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
    TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  end
  else
  begin
    GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
    TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
  end;

  { if there is no text or no bitmap, then Spacing is irrelevant }
  if (TextSize.X = 0) or (GlyphSize.X = 0) then
    Spacing := 0;

  { adjust Margin and Spacing }
  if Margin = -1 then
  begin
    if Spacing < 0 then
    begin
      TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
        Margin := (ClientSize.X - TotalSize.X) div 3
      else
        Margin := (ClientSize.Y - TotalSize.Y) div 3;
      Spacing := Margin;
    end
    else
    begin
      TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y +
      Spacing + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
        Margin := (ClientSize.X - TotalSize.X + 1) div 2
      else
        Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
    end;
  end
  else
  begin
    if Spacing < 0 then
    begin
      TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -
        (Margin + GlyphSize.Y));
      if Layout in [blGlyphLeft, blGlyphRight] then
        Spacing := (TotalSize.X - TextSize.X) div 2
      else
        Spacing := (TotalSize.Y - TextSize.Y) div 2;
    end;
  end;

  case Layout of
    blGlyphLeft:
      begin
        GlyphPos.X := Margin;
        TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
      end;
    blGlyphRight:
      begin
        GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
        TextPos.X := GlyphPos.X - Spacing - TextSize.X;
      end;
    blGlyphTop:
      begin
        GlyphPos.Y := Margin;
        TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
      end;
    blGlyphBottom:
      begin
        GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
        TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
      end;
  end;

  { fixup the result variables }
  Inc(GlyphPos.X, Client.Left + Offset.X);
  Inc(GlyphPos.Y, Client.Top + Offset.Y);

  OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X, TextPos.Y + Client.Top + Offset.Y);
end;

function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
  const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
  Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean;
  BiDiFlags: LongInt): TRect;
var
  GlyphPos: TPoint;
begin
  CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
  GlyphPos, Result, BiDiFlags);
  DrawButtonGlyph(Canvas, GlyphPos, State, Transparent);
  DrawButtonText(Canvas, Caption, Result, State, BiDiFlags);
end;


{ TBitBtnEX }

class constructor TBitBtnEX.Create;
begin
  TCustomStyleEngine.RegisterStyleHook(TBitBtnEX, TBitBtnEXStyleHook);
end;

class destructor TBitBtnEX.Destroy;
begin
  TCustomStyleEngine.UnRegisterStyleHook(TBitBtnEX, TBitBtnEXStyleHook);
end;


constructor TBitBtnEX.Create(AOwner: TComponent);
begin
  FGlyph := TButtonGlyph.Create;
  TButtonGlyph(FGlyph).OnChange := GlyphChanged;
  inherited Create(AOwner);
  FCanvas := TCanvas.Create;
  FStyle := bsStandard; // FStyleの値変更
  FColor := clBtnFace;  // Buttonの色初期値追加
  FBevelWidth := 1;     // BevelWidthの初期値追加
  FKind := bkCustom;
  FLayout := blGlyphLeft;
  FSpacing := 4;
  FMargin := -1;
  ControlStyle := ControlStyle + [csReflector, csPaintBlackOpaqueOnGlass];
  DoubleBuffered := True;
end;

destructor TBitBtnEX.Destroy;
begin
  inherited Destroy;
  TButtonGlyph(FGlyph).Free;
  FCanvas.Free;
end;

procedure TBitBtnEX.CreateHandle;
var
  State: TButtonState;
begin
  if Enabled then
    State := bsUp
  else
    State := bsDisabled;
  inherited CreateHandle;
  TButtonGlyph(FGlyph).CreateButtonGlyph(State);
end;

procedure TBitBtnEX.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do Style := Style or BS_OWNERDRAW;
end;

procedure TBitBtnEX.SetButtonStyle(ADefault: Boolean);
begin
  if ADefault <> IsFocused then
  begin
    IsFocused := ADefault;
    Refresh;
  end;
end;

procedure TBitBtnEX.CreateWnd; // Create時SetRegionの追加
begin
  inherited CreateWnd;
  SetRegion;
end;

procedure TBitBtnEX.Resize;    // ResizeのSetRegionの追加
begin
  inherited Resize;
  SetRegion;
//  if assigned(FOnResize) then // BitBtnにOnResizeなし
//  FOnResize(Self);
end;

procedure TBitBtnEX.SetRegion; // 楕円形 又は 四角形のRegionの設定追加
  var region: HRGN;
begin
  if FStyle = BsOvalDRaw then begin                           // 楕円形の場合 Regionの設定変更
    Region := CreateEllipticRgn(0, 0 , width + 1, height + 1);  // 楕円形の指定;
//  else // 四角形は設定されているので不要
//    Region := CreateRoundRectRgn (0, 0, Width + 1, Height + 1, 2, 2); // 四角形の指定
    SetWindowRgn(Handle, Region, True);
    DeleteObject(Region);
  end;
end;

procedure TBitBtnEX.UpdateStyleElements;
begin
  Invalidate;
end;

procedure TBitBtnEX.Click;
var
  Form: TCustomForm;
  Control: TWinControl;
begin
  case FKind of
    bkClose:
      begin
        Form := GetParentForm(Self);
        if Form <> nil then Form.Close
                       else inherited Click;
      end;
    bkHelp:
      begin
        Control := Self;
        while (Control <> nil) and
              (((Control.HelpType = htContext) and (Control.HelpContext = 0)) or
              ((Control.HelpType = htKeyword) and (Control.HelpKeyword = ''))) do
          Control := Control.Parent;
        if Control <> nil then
        begin
          if Control.HelpType = htContext then
            Application.HelpContext(Control.HelpContext)
          else
            Application.HelpKeyword(Control.HelpKeyword);
        end
        else
          inherited Click;
      end;
    else
      inherited Click;
  end;
end;

procedure TBitBtnEX.CNMeasureItem(var Message: TWMMeasureItem);
var
  Temp: PMeasureItemStruct;
begin
  Temp := Message.MeasureItemStruct;
  with Temp^ do
  begin
    itemWidth := Width;
    itemHeight := Height;
  end;
end;

procedure TBitBtnEX.CNDrawItem(var Message: TWMDrawItem);
begin
  DrawItem(Message.DrawItemStruct^);
end;

// **************************************************
// 影部RGB設定 追加
function TBitBtnEX.HLS2RGB(const HLS: TColorVector): TColorVector;
const
  Hue: array[0..5, 0..2] of Integer = (
  ( 1, -1, -1),   // red
  ( 1, 1, -1),    // yellow
  (-1, 1, -1),    // green
  (-1, 1, 1),     // cyan
  (-1, -1, 1),    // blue
  ( 1, -1, 1));   // magenta
  Components: array[0..2] of string = (
  'Hue',
  'Luminance',
  'Saturation');
var
  i, j, k: Integer;
  x: Double;
begin
  for i := Low(HLS.Coord) to High(HLS.Coord) do
    if (HLS.Coord[i] < 0) or (HLS.Coord[i] > 1) then
      raise EColorConv.CreateFmt('HLS2RGB: 0 <= %s value <= 1 required', [Components[i]]);

  j := Trunc(HLS.H * 6) mod 6;
  k := (j+1) mod 6;
  x := Frac(HLS.H * 6);
  for i := 0 to 2 do
    Result.Coord[i] := Hue[j, i] + x * (Hue[k, i] - Hue[j, i]);
  for i := 0 to 2 do Result.Coord[i] := Result.Coord[i] * HLS.S;
  if HLS.L <= 0.5 then
    for i := 0 to 2 do Result.Coord[i] := HLS.L * (Result.Coord[i] + 1)
  else
    for i := 0 to 2 do Result.Coord[i] := HLS.L + Result.Coord[i] * (1 - HLS.L);

  for i := 0 to 2 do
    if Result.Coord[i] < 0 then Result.Coord[i] := 0 else
      if Result.Coord[i] > 1 then Result.Coord[i] := 1;
end;

// 影部係数設定 追加
function TBitBtnEX.RGB2HLS(const RGB: TColorVector): TColorVector;
const
  Epsilon = 1E-8;
  Components: array[0..2] of string = (
    'Red',
    'Green',
    'Blue');
var
  i, k: Integer;
  x: Double;
  V: TColorVector;
  W: TColorVector;
//  W: TColorVector absolute Result;
  Hue: Double;
  Sat: Double;
  Lum: Double;

  function GetHue: Double;
  begin
    case k of
      0: if W.G > W.B then Result := 2 + (W.B + 1) / 2
         else Result := 4 - (W.G + 1) / 2;
      1: if W.B > W.R then Result := 4 + (W.R + 1) / 2
         else Result := 6 - (W.B + 1) / 2;
      2: if W.R > W.G then Result := (W.G + 1) / 2
         else Result := 2 - (W.R + 1) / 2;
      else Result := 0;
    end;
    Result := Result / 6;
  end;

begin
  for i := Low(RGB.Coord) to High(RGB.Coord) do
    if (RGB.Coord[i] < 0) or (RGB.Coord[i] > 1) then
      raise EColorConv.CreateFmt('RGB2HLS: 0 <= %s value <= 1 required', [Components[i]]);

  x := 0;
  for i := 0 to 2 do
  begin
    V.Coord[i] := 2 * RGB.Coord[i] - 1;   // [0, 1] -> [-1, 1]
    if Abs(V.Coord[i]) > x then
    begin
      x := Abs(V.Coord[i]);
      k := i;                             // index of RGB coordinate most different from 0.5
    end;
  end;
  if x < Epsilon then                    // middle grey
  begin
    W.H := 0;
    W.L := 0.5;                           // could be RGB.G or RGB.B as well
    W.S := 0;
    Result := W;
    Exit;
  end
  else x := 1 / x;
  for i := 0 to 2 do W.Coord[i] := V.Coord[i] * x;
  x := 0;
  if V.Coord[k] <= 0 then
  begin
    for i := 0 to 2 do if (W.Coord[i] + 1) > x then x := W.Coord[i] + 1;
    if x < Epsilon then                  // R = G = B: location on grey axis
    begin
      W.H := 0;
      W.L := RGB.R;                       // could be RGB.G or RGB.B as well
      W.S := 0;
      Result := W;
      Exit;
    end
    else x := 2 / x;
    for i := 0 to 2 do W.Coord[i] := x * (W.Coord[i] + 1) - 1;
    Hue := GetHue;

    if Abs(V.G - V.R) > Epsilon then
      Sat := (V.G - V.R) / (W.Coord[1] * (V.R + 1) - W.Coord[0] * (V.G + 1))
    else if Abs(V.B - V.G) > Epsilon then
      Sat := (V.B - V.G) / (W.Coord[2] * (V.G + 1) - W.Coord[1] * (V.B + 1))
    else if Abs(V.B - V.R) > Epsilon then
         Sat := (V.B - V.R) / (W.Coord[2] * (V.R + 1) - W.Coord[0] * (V.B + 1))
    else Sat := 0;

    if Abs(W.Coord[1] - W.Coord[0]) > Epsilon then
      Lum := (W.Coord[1] * (V.R + 1) - W.Coord[0] * (V.G + 1)) / (W.Coord[1] - W.Coord[0])
    else if Abs(W.Coord[2] - W.Coord[1]) > Epsilon then
      Lum := (W.Coord[2] * (V.G + 1) - W.Coord[1] * (V.B + 1)) / (W.Coord[2] - W.Coord[1])
    else if Abs(W.Coord[2] - W.Coord[0]) > Epsilon then
      Lum := (W.Coord[2] * (V.R + 1) - W.Coord[0] * (V.B + 1)) / (W.Coord[2] - W.Coord[0])
    else Lum := V.R + 1;
    Lum := Lum * 0.5;
  end else
  begin
    for i := 0 to 2 do if (1 - W.Coord[i]) > x then x := 1 - W.Coord[i];
    if x < Epsilon then  // R = G = B: location on grey axis
    begin
      W.H := 0;
      W.L := RGB.R;      // could be RGB.G or RGB.B as well
      W.S := 0;
      Result := W;
      Exit;
    end
    else x := 2 / x;
    for i := 0 to 2 do W.Coord[i] := x * (W.Coord[i] - 1) + 1;
    x := 1;
    for i := 0 to 2 do
      if W.Coord[i] < x then
      begin
        x := W.Coord[i];
        k := i;
      end;
    Hue := GetHue;

    if Abs(V.G - V.R) > Epsilon then
      Sat := (V.G - V.R) / (W.Coord[0] * (V.G - 1) - W.Coord[1] * (V.R - 1))
    else if Abs(V.B - V.G) > Epsilon then
      Sat := (V.B - V.G) / (W.Coord[1] * (V.B - 1) - W.Coord[2] * (V.G - 1))
    else if Abs(V.B - V.R) > Epsilon then
      Sat := (V.B - V.R) / (W.Coord[0] * (V.B - 1) - W.Coord[2] * (V.R - 1))
    else Sat := 0;

    if Abs(W.Coord[1] - W.Coord[0]) > Epsilon then
      Lum := (W.Coord[1] * (V.R - 1) - W.Coord[0] * (V.G - 1)) / (W.Coord[1] - W.Coord[0])
    else if Abs(W.Coord[2] - W.Coord[1]) > Epsilon then
      Lum := (W.Coord[2] * (V.G - 1) - W.Coord[1] * (V.B - 1)) / (W.Coord[2] - W.Coord[1])
    else if Abs(W.Coord[2] - W.Coord[0]) > Epsilon then
      Lum := (W.Coord[2] * (V.R - 1) - W.Coord[0] * (V.B - 1)) / (W.Coord[2] - W.Coord[0])
    else Lum := V.R - 1;
    Lum := 1 + Lum * 0.5;
  end;
  W.H := Hue;
  W.L := Lum;
  W.S := Sat;

  for i := 0 to 2 do
    if W.Coord[i] < 0 then W.Coord[i] := 0 else
    if W.Coord[i] > 1 then W.Coord[i] := 1;
  Result := W;
end;

// BevelColorの明暗色設定 追加
procedure TBitBtnEX.Get3DColors(FaceColor: TColor; var HighLightColor, ShadowColor: TColor; HLFactor, ShFactor: single);
var
  V,HLS : TColorVector;
  R,G,B : Byte;
begin
  FaceColor := ColorToRGB(FaceColor);
  R := GetRValue(FaceColor);
  G := GetGValue(FaceColor);
  B := GetBValue(FaceColor);
  HighLightColor := RGB(
    255 - round((256 - R) * HLFactor),
    255 - round((256 - G) * HLFactor),
    255 - round((256 - B) * HLFactor));
  V.R := R / 255;
  V.G := G / 255;
  V.B := B / 255;
  HLS := RGB2HLS(V);
  HLS.L := HLS.L * ShFactor; // Luminance := Luminance * Shadowfactor
  V := HLS2RGB(HLS);
    ShadowColor := RGB(
    Round(V.R * 255),
    Round(V.G * 255),
    Round(V.B * 255));
end;

// Bevel部の描画 追加
procedure TBitBtnEX.PaintBorder(FState: Integer);
begin
  Get3DColors(FColor, FColorHighlight, FColorShadow, (10 - FHLContrast) / 10, (10 - FShContrast) / 10); // BevelColorの明暗色設定 追加
  with FCanvas do begin
    Pen.Style := psSolid;
    Brush.Style := bsSolid;
    if FState = -1 then begin // down
      Pen.Color := FColorShadow;
      Brush.Color := FColorShadow;
    end;
    if FState = 1 then begin // up
      Pen.Color := FColorHighlight;
      Brush.Color := FColorHighlight;
    end;
    if FState = 0 then Pen.Color := FColor; // Flat
    Pie(1, 1, Width - 1, Height- 1,
    Width div 5 * 4, Height div 5,
    Width div 5, Height div 5 * 4);
    if FState = -1 then begin // down
      Pen.Color := FColorHighlight;
      Brush.Color := FColorHighlight;
    end;
    if FState = 1 then begin // up
      Pen.Color := FColorShadow;
      Brush.Color := FColorShadow;
    end;
    Pie(1, 1, Width - 1, Height - 1,
      Width div 5, Height div 5 * 4,
      Width div 5 * 4, Height div 5);
  end;
end;

procedure TBitBtnEX.DrawItem(const DrawItemStruct: TDrawItemStruct);
const
  WordBreakFlag: array[Boolean] of Integer = (0, DT_WORDBREAK);
var
  LogBrush :TLogBrush;
  IsDown, IsDefault: Boolean;
  State: TButtonState;
  R: TRect;
  Flags: Longint;
  Details: TThemedElementDetails;
  Button: TThemedButton;
  Offset: TPoint;
  LStyle: TCustomStyleServices;
  FontColor : Tcolor;
begin
  R := ClientRect;

  with DrawItemStruct do
  begin
    FCanvas.Handle := hDC;
    FCanvas.Font := Self.Font;
    IsDown := itemState and ODS_SELECTED <> 0;
    IsDefault := itemState and ODS_FOCUS <> 0;

    if not Enabled then State := bsDisabled
    else if IsDown then State := bsDown
    else State := bsUp;
  end;

// *******************************************************
  if FStyle = BsOvalDRaw then begin // OvalButton指定時の描画部追加
    FCanvas.Pen.Style := psSolid;

    FCanvas.Pen.Color := clWindowFrame;
    FCanvas.Pen.Width := 1;
    FCanvas.Brush.Style := bsSolid;
    InflateRect(R, -FBevelWidth, -FBevelWidth); // べベル幅分縦横を小さくします  

    if IsDown then
    begin
      PaintBorder(-1); // ボタンダウン時Bevel描画
      FCanvas.Pen.Color := FColorShadow;
      FCanvas.Brush.Color := FColor;
      FCanvas.Ellipse(R.Left, R.Top, R.Right, R.Bottom); // Bevelの内側塗りつぶし
    end
    else
    begin
      PaintBorder(1); // ボタン通常時時Bevel描画
      FCanvas.Brush.Style := bsSolid;
      FCanvas.Brush.Color := FColor;
      FCanvas.Ellipse(R.Left, R.Top, R.Right, R.Bottom); // Bevelの内側塗りつぶし
    end;

    if not IsFocused and not FMouseInControl then PaintBorder(0); // Focuseがなくマウスカーソルも上にいなかったら全体塗りつぶし

    FCanvas.Font := Self.Font; // Fontの取得
    R := ClientRect; // 描画枠取得
    if IsDown then begin
      OffsetRect(R, 1, 1); // 描画枠１ピクセル右下に移動
    end;
    FontColor := FCanvas.Font.Color; // フォントカラーのバックアップ
    if not Enabled then begin // フォントデスェブル色設定
      if FColor = ClGray then FCanvas.Font.Color := clLtGray
      else FCanvas.Font.Color := clGray;
    end;
    TButtonGlyph(FGlyph).FThemesEnabled := ThemeControl(Self); // テーマフラグの取得
    TButtonGlyph(FGlyph).Draw(FCanvas, R, Point(0,0), Caption, FLayout, FMargin, // 画像とCaptionの描画
      FSpacing, State, True, DrawTextBiDiModeFlags(0) or WordBreakFlag[WordWrap]); // TransparentをTrueに設定
    FCanvas.Font.Color := FontColor; // フォント色元へ戻し

    if IsFocused and IsDefault then // フォーカス枠の描画
    begin
      LogBrush.lbStyle := BS_SOLID;
      LogBrush.lbColor := ClBlack;
      LogBrush.lbHatch := 0;
      InflateRect(R, - FBevelWidth - 3, - FBevelWidth - 3);
      with FCanvas do begin
        Pen.Handle :=ExtCreatePen(PS_COSMETIC // 単純な幅が 1 のコスメティックペン
//                                  or PS_SOLID
//                                  or PS_ENDCAP_SQUARE
                                  or PS_ALTERNATE, // 1 ピクセルおきに描画を行うペン,
                                  1,         // ペンの幅1
                                 LogBrush,   // 黒色指定
                                 0,nil);     // nil PS_USERSTYLEの指定なし

        Pen.Mode := pmNotXor; // ペンモードセット

        Ellipse(R.Left, R.Top, R.Right, R.Bottom); // フォーカス枠作図
      end;
    end;

    FCanvas.Pen.Mode := PmCopy; // ペンモードセット
    R := ClientRect;
    FCanvas.Pen.Style := PsSolid;
    FCanvas.Brush.Style := bsClear;
    if not Enabled then begin
      if FColor = clSilver then FCanvas.Pen.Color := clBtnface
      else FCanvas.Pen.Color := clLtGray;
    end
    else begin
      if FColor = clWindowFrame then FCanvas.Pen.Color := clBlack
      else FCanvas.Pen.Color := clWindowFrame;
    end;
    FCanvas.Ellipse(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1); // 一番外側のフレーム枠描画
  end
// **************************************************************************
  else begin // Bitbtn 描画部 BsColorDRaw 追加
    if ThemeControl(Self) then
    begin
      LStyle := StyleServices;
      if not Enabled then
        Button := tbPushButtonDisabled
      else
        if IsDown then
          Button := tbPushButtonPressed
        else
          if FMouseInControl then
            Button := tbPushButtonHot
          else
            if IsFocused or IsDefault then
              Button := tbPushButtonDefaulted
            else
              Button := tbPushButtonNormal;

      Details := LStyle.GetElementDetails(Button);
      // Parent background.
      if not (csGlassPaint in ControlState) then
        LStyle.DrawParentBackground(Handle, DrawItemStruct.hDC, Details, True)
      else
        FillRect(DrawItemStruct.hDC, R, GetStockObject(BLACK_BRUSH));
      // Button shape.
      LStyle.DrawElement(DrawItemStruct.hDC, Details, DrawItemStruct.rcItem);
// **************************************
      if FStyle = BsColorDRaw then begin // BsColorDRaw追加 buttonの中を指定色で再描画 追加
        R := ClientRect;
        if Fcolor = clAqua then FCanvas.Pen.Width := 2
        else FCanvas.Pen.Width := 1;
        FCanvas.Pen.Color := clAqua;
        FCanvas.Brush.Color := Fcolor;
        if FMouseInControl then begin
          FCanvas.Pen.Style := PsSolid;
          FCanvas.RoundRect(R.Left + 5, R.Top + 5, R.Right - 4, R.Bottom - 4, 4, 4);
        end
        else begin
          FCanvas.Pen.Style := PsClear;
          FCanvas.RoundRect(R.Left + 5, R.Top + 5, R.Right - 4, R.Bottom - 4, 2, 2);
        end;
      end;
// **************************************
      LStyle.GetElementContentRect(FCanvas.Handle, Details, DrawItemStruct.rcItem, R);

      Offset := Point(0, 0);
      TButtonGlyph(FGlyph).FPaintOnGlass := csGlassPaint in ControlState;
      TButtonGlyph(FGlyph).FThemeDetails := Details;
      TButtonGlyph(FGlyph).FThemesEnabled := ThemeControl(Self);
      TButtonGlyph(FGlyph).FThemeTextColor := seFont in StyleElements;
      TButtonGlyph(FGlyph).Draw(FCanvas, R, Offset, Caption, FLayout, FMargin, FSpacing, State, False,
      DrawTextBiDiModeFlags(0) or WordBreakFlag[WordWrap]);

      if IsFocused and IsDefault and LStyle.IsSystemStyle then
      begin
        FCanvas.Pen.Color := clWindowFrame;
        FCanvas.Brush.Color := clBtnFace;
        DrawFocusRect(FCanvas.Handle, R);
      end;
    end
    else
    begin
      Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
      if IsDown then Flags := Flags or DFCS_PUSHED;
      if DrawItemStruct.itemState and ODS_DISABLED <> 0 then
        Flags := Flags or DFCS_INACTIVE;

      { DrawFrameControl doesn't allow for drawing a button as the
        default button, so it must be done here. }
      if IsFocused or IsDefault then
      begin
        FCanvas.Pen.Color := clWindowFrame;
        FCanvas.Pen.Width := 1;
        FCanvas.Brush.Style := bsClear;
        FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);

        { DrawFrameControl must draw within this border }
        InflateRect(R, -1, -1);
      end;
// ****************************
      { DrawFrameControl does not draw a pressed button correctly }
      if IsDown then
      begin
        FCanvas.Pen.Color := clBtnShadow;
        FCanvas.Pen.Width := 1;
        if FStyle = BsColorDRaw then // BsColorDRaw追加 buttonの中を指定色で再描画 追加
          FCanvas.Brush.Color := FColor
        else
          FCanvas.Brush.Color := clBtnFace;
        FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
        InflateRect(R, -1, -1);
      end
      else begin
        DrawFrameControl(DrawItemStruct.hDC, R, DFC_BUTTON, Flags);
        if FStyle = BsColorDRaw then begin // BsColorDRaw追加 buttonの中を指定色で再描画 追加
          FCanvas.Pen.Style := PsClear;
          FCanvas.Brush.Color := FColor;
          FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
        end;
      end;
      FCanvas.Pen.Style := PsSolid;
// ****************************

      if IsFocused then
      begin
        R := ClientRect;
        InflateRect(R, -1, -1);
      end;

      FCanvas.Font := Self.Font;
      if IsDown then
        OffsetRect(R, 1, 1);

      TButtonGlyph(FGlyph).FThemesEnabled := ThemeControl(Self);
      TButtonGlyph(FGlyph).Draw(FCanvas, R, Point(0,0), Caption, FLayout, FMargin,
        FSpacing, State, True, DrawTextBiDiModeFlags(0) or WordBreakFlag[WordWrap]); // TransparentをTrueに設定

      if IsFocused and IsDefault then
      begin
        R := ClientRect;
        InflateRect(R, -4, -4);
        FCanvas.Pen.Color := clWindowFrame;
        FCanvas.Brush.Color := clBtnFace;
        DrawFocusRect(FCanvas.Handle, R);
      end;
    end;
  end;
  FCanvas.Handle := 0;
end;

procedure TBitBtnEX.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TBitBtnEX.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TBitBtnEX.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  Perform(WM_LBUTTONDOWN, Message.Keys, LPARAM(Word(Message.XPos) or (Word(Message.YPos) shr 16)));
end;

function TBitBtnEX.GetPalette: HPALETTE;
begin
  Result := Glyph.Palette;
end;

procedure TBitBtnEX.SetGlyph(Value: TBitmap);
begin
  TButtonGlyph(FGlyph).Glyph := Value as TBitmap;
  FModifiedGlyph := True;
  Invalidate;
end;

function TBitBtnEX.GetGlyph: TBitmap;
begin
  Result := TButtonGlyph(FGlyph).Glyph;
end;

procedure TBitBtnEX.GlyphChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure TBitBtnEX.InternalCopyImage(Image: TBitmap;
  ImageList: TCustomImageList; Index: Integer);
begin
  with Image do
  begin
    Width := ImageList.Width;
    Height := ImageList.Height;
    Canvas.Brush.Color := clFuchsia; //! for lack of a better color
    Canvas.FillRect(Rect(0,0, Width, Height));
    ImageList.Draw(Canvas, 0, 0, Index);
  end;
end;

function TBitBtnEX.IsCustom: Boolean;
var
  Link: TBitBtnEXActionLink;
begin
  Link := TBitBtnEXActionLink(ActionLink);
  Result := (Kind = bkCustom) and
    not ((Link <> nil) and Link.IsImageIndexLinked and Link.IsGlyphLinked(Link.FImageIndex));
end;

procedure TBitBtnEX.SetStyle(Value: TButtonStyle);
begin
  if Value <> FStyle then
  begin
    FStyle := Value;
    Invalidate;
  end;
end;

procedure TBitBtnEX.SetKind(Value: TBitBtnEXKind);
begin
  if Value <> FKind then
  begin
    if Value <> bkCustom then
    begin
      Default := Value in [bkOK, bkYes];
      Cancel := Value in [bkCancel, bkNo];

      if ((csLoading in ComponentState) and (Caption = '')) or
          (not (csLoading in ComponentState)) then
      begin
        if BitBtnExCaptions[Value] <> nil then
          aption := BitBtnExCaptions[Value];
//      Caption := LoadResString(BitBtnExCaptions[Value]);
      end;

      ModalResult := BitBtnExModalResults[Value];
      TButtonGlyph(FGlyph).Glyph := GeTBitBtnEXGlyph(Value);
      NumGlyphs := 2;
      FModifiedGlyph := False;
    end;
    FKind := Value;
    Invalidate;
  end;
end;

function TBitBtnEX.IsCustomCaption: Boolean;
begin
  Result := AnsiCompareStr(Caption, BitBtnExCaptions[FKind]) <> 0;
//  Result := AnsiCompareStr(Caption, LoadResString(BitBtnExCaptions[FKind])) <> 0;
end;

function TBitBtnEX.GetKind: TBitBtnEXKind;
begin
  if FKind <> bkCustom then
  if ((FKind in [bkOK, bkYes]) xor Default) or
    ((FKind in [bkCancel, bkNo]) xor Cancel) or
    (ModalResult <> BitBtnExModalResults[FKind]) or
    FModifiedGlyph then
    FKind := bkCustom;
  Result := FKind;
end;

procedure TBitBtnEX.SetLayout(Value: TButtonLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    Invalidate;
  end;
end;

function TBitBtnEX.GetNumGlyphs: TNumGlyphs;
begin
  Result := TButtonGlyph(FGlyph).NumGlyphs;
end;

procedure TBitBtnEX.SetNumGlyphs(Value: TNumGlyphs);
begin
  if Value < 0 then Value := 1
  else if Value > 4 then Value := 4;
  if Value <> TButtonGlyph(FGlyph).NumGlyphs then
  begin
    TButtonGlyph(FGlyph).NumGlyphs := Value;
    Invalidate;
  end;
end;

// BevelWidthの設定　追加
procedure TBitBtnEX.SetBevelWidth(newValue: TBevelWidth);
begin
  if FBevelWidth <> newValue then begin
    FBevelWidth := newValue;
    Invalidate;
  end;
end;

// Ovalボタンの色設定追加
procedure TBitBtnEX.SetColor(newColor: TColor);
begin
  if FColor <> newColor then begin
    FColor := newColor;
    Invalidate;
  end;
end;

procedure TBitBtnEX.SetSpacing(Value: Integer);
begin
  if FSpacing <> Value then
  begin
    FSpacing := Value;
    Invalidate;
  end;
end;

procedure TBitBtnEX.SetMargin(Value: Integer);
begin
  if (Value <> FMargin) and (Value >= - 1) then
  begin
    FMargin := Value;
    Invalidate;
  end;
end;

procedure TBitBtnEX.CopyImage(ImageList: TCustomImageList; Index: Integer);
begin
  InternalCopyImage(Glyph, ImageList, Index);
end;

procedure TBitBtnEX.ActionChange(Sender: TObject; CheckDefaults: Boolean);
var
  Link: TBitBtnEXActionLink;
begin
  inherited ActionChange(Sender, CheckDefaults);
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      Link := TBitBtnEXActionLink(ActionLink);
      if CheckDefaults and not Link.IsGlyphLinked(Link.FImageIndex) and (not Glyph.Empty) then
        Exit;
      if CheckDefaults or (Link.FImageIndex <> -1) or (Link.FImageIndex <> ImageIndex) then
      begin
        Link.FImageIndex := ImageIndex;
        if ImageIndex <> -1 then
          Glyph := nil;
      end;
      { Copy image from action's imagelist }
      if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
        (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
        CopyImage(ActionList.Images, ImageIndex);
    end;
end;

procedure DestroyLocals; far;
var
  I: TBitBtnEXKind;
begin
  for I := Low(TBitBtnEXKind) to High(TBitBtnEXKind) do
    BitBtnExGlyphs[I].Free;
end;

procedure TBitBtnEX.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if StyleServices.Enabled and not FMouseInControl and not (csDesigning in ComponentState) then
  begin
    FMouseInControl := True;
    Repaint;
  end;
end;

procedure TBitBtnEX.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if StyleServices.Enabled and FMouseInControl then
  begin
    FMouseInControl := False;
    Repaint;
  end;
end;

function TBitBtnEX.GetActionLinkClass: TControlActionLinkClass;
begin
  Result := TBitBtnEXActionLink;
end;

{ TBinBtnStyleHook }

procedure TBitBtnEXStyleHook.DrawButton(ACanvas: TCanvas; AMouseInControl: Boolean);
const
  WordBreakFlag: array[Boolean] of Integer = (0, DT_WORDBREAK);
var
  Details: TThemedElementDetails;
  DrawRect: TRect;
  Offset: TPoint;
  State: TButtonState;
begin
  if not (Control is TBitBtnEX) then
  begin
    inherited;
    Exit;
  end;
  DrawRect := Control.ClientRect;
  if FPressed then
    Details := StyleServices.GetElementDetails(tbPushButtonPressed)
  else if AMouseInControl then
    Details := StyleServices.GetElementDetails(tbPushButtonHot)
  else if Focused then
    Details := StyleServices.GetElementDetails(tbPushButtonDefaulted)
  else if Control.Enabled then
    Details := StyleServices.GetElementDetails(tbPushButtonNormal)
  else
    Details := StyleServices.GetElementDetails(tbPushButtonDisabled);
  DrawRect := Control.ClientRect;
  StyleServices.DrawElement(ACanvas.Handle, Details, DrawRect);

  Offset := Point(0, 0);
  with TBitBtnEX(Control) do
  begin
    if not Enabled then State := bsDisabled
    else if FPressed then State := bsDown
    else State := bsUp;
    ACanvas.Font := Font;
    TButtonGlyph(FGlyph).FPaintOnGlass := False;
    TButtonGlyph(FGlyph).FThemeDetails := Details;
    TButtonGlyph(FGlyph).FThemesEnabled := True;
    TButtonGlyph(FGlyph).FThemeTextColor := seFont in StyleElements;
    TButtonGlyph(FGlyph).Draw(ACanvas, DrawRect, Offset, Caption, FLayout, FMargin, FSpacing, State, False,
    DrawTextBiDiModeFlags(0) or WordBreakFlag[WordWrap]);
  end;
end;

{ TBitBtnEXActionLink }

procedure TBitBtnEXActionLink.AssignClient(AClient: TObject);
begin
  inherited AssignClient(AClient);
  FClient := AClient as TBitBtnEX;
end;

constructor TBitBtnEXActionLink.Create(AClient: TObject);
begin
  inherited;
  FImageIndex := -1;
end;

function TBitBtnEXActionLink.IsImageIndexLinked: Boolean;
begin
  Result := inherited IsImageIndexLinked and
    (FImageIndex = TCustomAction(Action).ImageIndex);
end;

function TBitBtnEXActionLink.IsGlyphLinked(Index: TImageIndex): Boolean;
var
  LBitmap: TBitmap;
  Images: TCustomImageList;
begin
  Images := TCustomAction(Action).ActionList.Images;
  Result := (Images <> nil) and (FClient.Glyph <> nil) and
    (FClient.Glyph.Width = Images.Width) and (FClient.Glyph.Height = Images.Height);
  if Result then
  begin
    LBitmap := TBitmap.Create;
    try
      FClient.InternalCopyImage(LBitmap, Images, Index);
      Result := LBitmap.Equals(FClient.Glyph);
    finally
      LBitmap.Free;
    end;
  end;
end;

procedure TBitBtnEXActionLink.SetImageIndex(Value: Integer);
begin
  if IsImageIndexLinked or FClient.Glyph.Empty then
  begin
    if Action is TCustomAction then
      with TCustomAction(Action) do
        { Copy image from action's imagelist }
        if (ActionList <> nil) and (ActionList.Images <> nil) then
          if (Value >= 0) and (Value < ActionList.Images.Count) then
          begin
            if IsGlyphLinked(FImageIndex) or FClient.Glyph.Empty then
            FClient.CopyImage(ActionList.Images, Value);
          end
          else
            FClient.Glyph := nil;
    FImageIndex := Value;
    FClient.GlyphChanged(nil);
  end;
end;


initialization
  FillChar(BitBtnExGlyphs, SizeOf(BitBtnExGlyphs), 0);
finalization
  DestroyLocals;
end.

　　　　　BitbtnEx.zip

　　　　　コンポーネント一覧へ戻る