home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / BUTTONS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  45.1 KB  |  1,615 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1995,99 Inprise Corporation       }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Buttons;
  11.  
  12. {$S-,W-,R-,H+,X+}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
  18.   ExtCtrls, CommCtrl;
  19.     
  20. type
  21.   TButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
  22.   TButtonState = (bsUp, bsDisabled, bsDown, bsExclusive);
  23.   TButtonStyle = (bsAutoDetect, bsWin31, bsNew);
  24.   TNumGlyphs = 1..4;
  25.     
  26.   TSpeedButton = class(TGraphicControl)
  27.   private
  28.     FGroupIndex: Integer;
  29.     FGlyph: Pointer;
  30.     FDown: Boolean;
  31.     FDragging: Boolean;
  32.     FAllowAllUp: Boolean;
  33.     FLayout: TButtonLayout;
  34.     FSpacing: Integer;
  35.     FTransparent: Boolean;
  36.     FMargin: Integer;
  37.     FFlat: Boolean;
  38.     FMouseInControl: Boolean;
  39.     procedure GlyphChanged(Sender: TObject);
  40.     procedure UpdateExclusive;
  41.     function GetGlyph: TBitmap;
  42.     procedure SetGlyph(Value: TBitmap);
  43.     function GetNumGlyphs: TNumGlyphs;
  44.     procedure SetNumGlyphs(Value: TNumGlyphs);
  45.     procedure SetDown(Value: Boolean);
  46.     procedure SetFlat(Value: Boolean);
  47.     procedure SetAllowAllUp(Value: Boolean);
  48.     procedure SetGroupIndex(Value: Integer);
  49.     procedure SetLayout(Value: TButtonLayout);
  50.     procedure SetSpacing(Value: Integer);
  51.     procedure SetTransparent(Value: Boolean);
  52.     procedure SetMargin(Value: Integer);
  53.     procedure UpdateTracking;
  54.     procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
  55.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  56.     procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
  57.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  58.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  59.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  60.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  61.     procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
  62.     procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  63.   protected
  64.     FState: TButtonState;
  65.     procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
  66.     function GetPalette: HPALETTE; override;
  67.     procedure Loaded; override;
  68.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  69.       X, Y: Integer); override;
  70.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  71.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  72.       X, Y: Integer); override;
  73.     procedure Paint; override;
  74.     property MouseInControl: Boolean read FMouseInControl;
  75.   public
  76.     constructor Create(AOwner: TComponent); override;
  77.     destructor Destroy; override;
  78.     procedure Click; override;
  79.   published
  80.     property Action;
  81.     property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
  82.     property Anchors;
  83.     property BiDiMode;
  84.     property Constraints;
  85.     property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
  86.     property Down: Boolean read FDown write SetDown default False;
  87.     property Caption;
  88.     property Enabled;
  89.     property Flat: Boolean read FFlat write SetFlat default False;
  90.     property Font;
  91.     property Glyph: TBitmap read GetGlyph write SetGlyph;
  92.     property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
  93.     property Margin: Integer read FMargin write SetMargin default -1;
  94.     property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;
  95.     property ParentFont;
  96.     property ParentShowHint;
  97.     property ParentBiDiMode;
  98.     property PopupMenu;
  99.     property ShowHint;
  100.     property Spacing: Integer read FSpacing write SetSpacing default 4;
  101.     property Transparent: Boolean read FTransparent write SetTransparent default True;
  102.     property Visible;
  103.     property OnClick;
  104.     property OnDblClick;
  105.     property OnMouseDown;
  106.     property OnMouseMove;
  107.     property OnMouseUp;
  108.   end;
  109.     
  110.   TBitBtnKind = (bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose,
  111.     bkAbort, bkRetry, bkIgnore, bkAll);
  112.     
  113.   TBitBtn = class(TButton)
  114.   private
  115.     FCanvas: TCanvas;
  116.     FGlyph: Pointer;
  117.     FStyle: TButtonStyle;
  118.     FKind: TBitBtnKind;
  119.     FLayout: TButtonLayout;
  120.     FSpacing: Integer;
  121.     FMargin: Integer;
  122.     IsFocused: Boolean;
  123.     FModifiedGlyph: Boolean;
  124.     procedure DrawItem(const DrawItemStruct: TDrawItemStruct);
  125.     procedure SetGlyph(Value: TBitmap);
  126.     function GetGlyph: TBitmap;
  127.     function GetNumGlyphs: TNumGlyphs;
  128.     procedure SetNumGlyphs(Value: TNumGlyphs);
  129.     procedure GlyphChanged(Sender: TObject);
  130.     function IsCustom: Boolean;
  131.     function IsCustomCaption: Boolean;
  132.     procedure SetStyle(Value: TButtonStyle);
  133.     procedure SetKind(Value: TBitBtnKind);
  134.     function GetKind: TBitBtnKind;
  135.     procedure SetLayout(Value: TButtonLayout);
  136.     procedure SetSpacing(Value: Integer);
  137.     procedure SetMargin(Value: Integer);
  138.     procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
  139.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  140.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  141.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  142.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
  143.       message WM_LBUTTONDBLCLK;
  144.   protected
  145.     procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
  146.     procedure CreateHandle; override;
  147.     procedure CreateParams(var Params: TCreateParams); override;
  148.     function GetPalette: HPALETTE; override;
  149.     procedure SetButtonStyle(ADefault: Boolean); override;
  150.   public
  151.     constructor Create(AOwner: TComponent); override;
  152.     destructor Destroy; override;
  153.     procedure Click; override;
  154.   published
  155.     property Action;
  156.     property Anchors;
  157.     property BiDiMode;
  158.     property Cancel stored IsCustom;
  159.     property Caption stored IsCustomCaption;
  160.     property Constraints;
  161.     property Default stored IsCustom;
  162.     property Enabled;
  163.     property Glyph: TBitmap read GetGlyph write SetGlyph stored IsCustom;
  164.     property Kind: TBitBtnKind read GetKind write SetKind default bkCustom;
  165.     property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
  166.     property Margin: Integer read FMargin write SetMargin default -1;
  167.     property ModalResult stored IsCustom;
  168.     property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs stored IsCustom default 1;
  169.     property ParentShowHint;
  170.     property ParentBiDiMode;
  171.     property ShowHint;
  172.     property Style: TButtonStyle read FStyle write SetStyle default bsAutoDetect;
  173.     property Spacing: Integer read FSpacing write SetSpacing default 4;
  174.     property TabOrder;
  175.     property TabStop;
  176.     property Visible;
  177.     property OnEnter;
  178.     property OnExit;
  179.   end;
  180.     
  181. function DrawButtonFace(Canvas: TCanvas; const Client: TRect;
  182.   BevelWidth: Integer; Style: TButtonStyle; IsRounded, IsDown,
  183.   IsFocused: Boolean): TRect;
  184.     
  185. implementation
  186.     
  187. uses Consts, SysUtils, ActnList, ImgList;
  188.     
  189. {$R BUTTONS.RES}
  190.     
  191. { TBitBtn data }
  192. var
  193.   BitBtnResNames: array[TBitBtnKind] of PChar = (
  194.     nil, 'BBOK', 'BBCANCEL', 'BBHELP', 'BBYES', 'BBNO', 'BBCLOSE',
  195.     'BBABORT', 'BBRETRY', 'BBIGNORE', 'BBALL');
  196.   BitBtnCaptions: array[TBitBtnKind] of Pointer = (
  197.     nil, @SOKButton, @SCancelButton, @SHelpButton, @SYesButton, @SNoButton,
  198.     @SCloseButton, @SAbortButton, @SRetryButton, @SIgnoreButton,
  199.     @SAllButton);
  200.   BitBtnModalResults: array[TBitBtnKind] of TModalResult = (
  201.     0, mrOk, mrCancel, 0, mrYes, mrNo, 0, mrAbort, mrRetry, mrIgnore,
  202.     mrAll);
  203.     
  204. var
  205.   BitBtnGlyphs: array[TBitBtnKind] of TBitmap;
  206.     
  207. { DrawButtonFace - returns the remaining usable area inside the Client rect.}
  208. function DrawButtonFace(Canvas: TCanvas; const Client: TRect;
  209.   BevelWidth: Integer; Style: TButtonStyle; IsRounded, IsDown,
  210.   IsFocused: Boolean): TRect;
  211. var
  212.   NewStyle: Boolean;
  213.   R: TRect;
  214.   DC: THandle;
  215. begin
  216.   NewStyle := ((Style = bsAutoDetect) and NewStyleControls) or (Style = bsNew);
  217.     
  218.   R := Client;
  219.   with Canvas do
  220.   begin
  221.     if NewStyle then
  222.     begin
  223.       Brush.Color := clBtnFace;
  224.       Brush.Style := bsSolid;
  225.       DC := Canvas.Handle;    { Reduce calls to GetHandle }
  226.     
  227.       if IsDown then
  228.       begin    { DrawEdge is faster than Polyline }
  229.         DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT);              { black     }
  230.         DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT);          { btnhilite }
  231.         Dec(R.Bottom);
  232.         Dec(R.Right);
  233.         Inc(R.Top);
  234.         Inc(R.Left);
  235.         DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); { btnshadow }
  236.       end
  237.       else
  238.       begin
  239.         DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT);          { black }
  240.         Dec(R.Bottom);
  241.         Dec(R.Right);
  242.         DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT);              { btnhilite }
  243.         Inc(R.Top);
  244.         Inc(R.Left);
  245.         DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); { btnshadow }
  246.       end;
  247.     end
  248.     else
  249.     begin
  250.       Pen.Color := clWindowFrame;
  251.       Brush.Color := clBtnFace;
  252.       Brush.Style := bsSolid;
  253.       Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  254.     
  255.       { round the corners - only applies to Win 3.1 style buttons }
  256.       if IsRounded then
  257.       begin
  258.         Pixels[R.Left, R.Top] := clBtnFace;
  259.         Pixels[R.Left, R.Bottom - 1] := clBtnFace;
  260.         Pixels[R.Right - 1, R.Top] := clBtnFace;
  261.         Pixels[R.Right - 1, R.Bottom - 1] := clBtnFace;
  262.       end;
  263.     
  264.       if IsFocused then
  265.       begin
  266.         InflateRect(R, -1, -1);
  267.         Brush.Style := bsClear;
  268.         Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  269.       end;
  270.     
  271.       InflateRect(R, -1, -1);
  272.       if not IsDown then
  273.         Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, BevelWidth)
  274.       else
  275.       begin
  276.         Pen.Color := clBtnShadow;
  277.         PolyLine([Point(R.Left, R.Bottom - 1), Point(R.Left, R.Top),
  278.           Point(R.Right, R.Top)]);
  279.       end;
  280.     end;
  281.   end;
  282.     
  283.   Result := Rect(Client.Left + 1, Client.Top + 1,
  284.     Client.Right - 2, Client.Bottom - 2);
  285.   if IsDown then OffsetRect(Result, 1, 1);
  286. end;
  287.     
  288. function GetBitBtnGlyph(Kind: TBitBtnKind): TBitmap;
  289. begin
  290.   if BitBtnGlyphs[Kind] = nil then
  291.   begin
  292.     BitBtnGlyphs[Kind] := TBitmap.Create;
  293.     BitBtnGlyphs[Kind].LoadFromResourceName(HInstance, BitBtnResNames[Kind]);
  294.   end;
  295.   Result := BitBtnGlyphs[Kind];
  296. end;
  297.     
  298. type
  299.   TGlyphList = class(TImageList)
  300.   private
  301.     Used: TBits;
  302.     FCount: Integer;
  303.     function AllocateIndex: Integer;
  304.   public
  305.     constructor CreateSize(AWidth, AHeight: Integer);
  306.     destructor Destroy; override;
  307.     function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  308.     procedure Delete(Index: Integer);
  309.     property Count: Integer read FCount;
  310.   end;
  311.     
  312.   TGlyphCache = class
  313.   private
  314.     GlyphLists: TList;
  315.   public
  316.     constructor Create;
  317.     destructor Destroy; override;
  318.     function GetList(AWidth, AHeight: Integer): TGlyphList;
  319.     procedure ReturnList(List: TGlyphList);
  320.     function Empty: Boolean;
  321.   end;
  322.     
  323.   TButtonGlyph = class
  324.   private
  325.     FOriginal: TBitmap;
  326.     FGlyphList: TGlyphList;
  327.     FIndexs: array[TButtonState] of Integer;
  328.     FTransparentColor: TColor;
  329.     FNumGlyphs: TNumGlyphs;
  330.     FOnChange: TNotifyEvent;
  331.     procedure GlyphChanged(Sender: TObject);
  332.     procedure SetGlyph(Value: TBitmap);
  333.     procedure SetNumGlyphs(Value: TNumGlyphs);
  334.     procedure Invalidate;
  335.     function CreateButtonGlyph(State: TButtonState): Integer;
  336.     procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
  337.       State: TButtonState; Transparent: Boolean);
  338.     procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
  339.       TextBounds: TRect; State: TButtonState; BiDiFlags: Longint);
  340.     procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
  341.       const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
  342.       Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
  343.       BiDiFlags: Longint);
  344.   public
  345.     constructor Create;
  346.     destructor Destroy; override;
  347.     { return the text rectangle }
  348.     function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
  349.       const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  350.       State: TButtonState; Transparent: Boolean; BiDiFlags: Longint): TRect;
  351.     property Glyph: TBitmap read FOriginal write SetGlyph;
  352.     property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;
  353.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  354.   end;
  355.     
  356. { TGlyphList }
  357.     
  358. constructor TGlyphList.CreateSize(AWidth, AHeight: Integer);
  359. begin
  360.   inherited CreateSize(AWidth, AHeight);
  361.   Used := TBits.Create;
  362. end;
  363.     
  364. destructor TGlyphList.Destroy;
  365. begin
  366.   Used.Free;
  367.   inherited Destroy;
  368. end;
  369.     
  370. function TGlyphList.AllocateIndex: Integer;
  371. begin
  372.   Result := Used.OpenBit;
  373.   if Result >= Used.Size then
  374.   begin
  375.     Result := inherited Add(nil, nil);
  376.     Used.Size := Result + 1;
  377.   end;
  378.   Used[Result] := True;
  379. end;
  380.     
  381. function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  382. begin
  383.   Result := AllocateIndex;
  384.   ReplaceMasked(Result, Image, MaskColor);
  385.   Inc(FCount);
  386. end;
  387.     
  388. procedure TGlyphList.Delete(Index: Integer);
  389. begin
  390.   if Used[Index] then
  391.   begin
  392.     Dec(FCount);
  393.     Used[Index] := False;
  394.   end;
  395. end;
  396.     
  397. { TGlyphCache }
  398.     
  399. constructor TGlyphCache.Create;
  400. begin
  401.   inherited Create;
  402.   GlyphLists := TList.Create;
  403. end;
  404.     
  405. destructor TGlyphCache.Destroy;
  406. begin
  407.   GlyphLists.Free;
  408.   inherited Destroy;
  409. end;
  410.     
  411. function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
  412. var
  413.   I: Integer;
  414. begin
  415.   for I := GlyphLists.Count - 1 downto 0 do
  416.   begin
  417.     Result := GlyphLists[I];
  418.     with Result do
  419.       if (AWidth = Width) and (AHeight = Height) then Exit;
  420.   end;
  421.   Result := TGlyphList.CreateSize(AWidth, AHeight);
  422.   GlyphLists.Add(Result);
  423. end;
  424.     
  425. procedure TGlyphCache.ReturnList(List: TGlyphList);
  426. begin
  427.   if List = nil then Exit;
  428.   if List.Count = 0 then
  429.   begin
  430.     GlyphLists.Remove(List);
  431.     List.Free;
  432.   end;
  433. end;
  434.     
  435. function TGlyphCache.Empty: Boolean;
  436. begin
  437.   Result := GlyphLists.Count = 0;
  438. end;
  439.     
  440. var
  441.   GlyphCache: TGlyphCache = nil;
  442.   ButtonCount: Integer = 0;
  443.  
  444. { TButtonGlyph }
  445.     
  446. constructor TButtonGlyph.Create;
  447. var
  448.   I: TButtonState;
  449. begin
  450.   inherited Create;
  451.   FOriginal := TBitmap.Create;
  452.   FOriginal.OnChange := GlyphChanged;
  453.   FTransparentColor := clOlive;
  454.   FNumGlyphs := 1;
  455.   for I := Low(I) to High(I) do
  456.     FIndexs[I] := -1;
  457.   if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
  458. end;
  459.     
  460. destructor TButtonGlyph.Destroy;
  461. begin
  462.   FOriginal.Free;
  463.   Invalidate;
  464.   if Assigned(GlyphCache) and GlyphCache.Empty then
  465.   begin
  466.     GlyphCache.Free;
  467.     GlyphCache := nil;
  468.   end;
  469.   inherited Destroy;
  470. end;
  471.     
  472. procedure TButtonGlyph.Invalidate;
  473. var
  474.   I: TButtonState;
  475. begin
  476.   for I := Low(I) to High(I) do
  477.   begin
  478.     if FIndexs[I] <> -1 then FGlyphList.Delete(FIndexs[I]);
  479.     FIndexs[I] := -1;
  480.   end;
  481.   GlyphCache.ReturnList(FGlyphList);
  482.   FGlyphList := nil;
  483. end;
  484.     
  485. procedure TButtonGlyph.GlyphChanged(Sender: TObject);
  486. begin
  487.   if Sender = FOriginal then
  488.   begin
  489.     FTransparentColor := FOriginal.TransparentColor;
  490.     Invalidate;
  491.     if Assigned(FOnChange) then FOnChange(Self);
  492.   end;
  493. end;
  494.     
  495. procedure TButtonGlyph.SetGlyph(Value: TBitmap);
  496. var
  497.   Glyphs: Integer;
  498. begin
  499.   Invalidate;
  500.   FOriginal.Assign(Value);
  501.   if (Value <> nil) and (Value.Height > 0) then
  502.   begin
  503.     FTransparentColor := Value.TransparentColor;
  504.     if Value.Width mod Value.Height = 0 then
  505.     begin
  506.       Glyphs := Value.Width div Value.Height;
  507.       if Glyphs > 4 then Glyphs := 1;
  508.       SetNumGlyphs(Glyphs);
  509.     end;
  510.   end;
  511. end;
  512.     
  513. procedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);
  514. begin
  515.   if (Value <> FNumGlyphs) and (Value > 0) then
  516.   begin
  517.     Invalidate;
  518.     FNumGlyphs := Value;
  519.     GlyphChanged(Glyph);
  520.   end;
  521. end;
  522.     
  523. function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;
  524. const
  525.   ROP_DSPDxax = $00E20746;
  526. var
  527.   TmpImage, DDB, MonoBmp: TBitmap;
  528.   IWidth, IHeight: Integer;
  529.   IRect, ORect: TRect;
  530.   I: TButtonState;
  531.   DestDC: HDC;
  532. begin
  533.   if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
  534.   Result := FIndexs[State];
  535.   if Result <> -1 then Exit;
  536.   if (FOriginal.Width or FOriginal.Height) = 0 then Exit;
  537.   IWidth := FOriginal.Width div FNumGlyphs;
  538.   IHeight := FOriginal.Height;
  539.   if FGlyphList = nil then
  540.   begin
  541.     if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
  542.     FGlyphList := GlyphCache.GetList(IWidth, IHeight);
  543.   end;
  544.   TmpImage := TBitmap.Create;
  545.   try
  546.     TmpImage.Width := IWidth;
  547.     TmpImage.Height := IHeight;
  548.     IRect := Rect(0, 0, IWidth, IHeight);
  549.     TmpImage.Canvas.Brush.Color := clBtnFace;
  550.     TmpImage.Palette := CopyPalette(FOriginal.Palette);
  551.     I := State;
  552.     if Ord(I) >= NumGlyphs then I := bsUp;
  553.     ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
  554.     case State of
  555.       bsUp, bsDown,
  556.       bsExclusive:
  557.         begin
  558.           TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
  559.           if FOriginal.TransparentMode = tmFixed then
  560.             FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor)
  561.           else
  562.             FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
  563.         end;
  564.       bsDisabled:
  565.         begin
  566.           MonoBmp := nil;
  567.           DDB := nil;
  568.           try
  569.             MonoBmp := TBitmap.Create;
  570.             DDB := TBitmap.Create;
  571.             DDB.Assign(FOriginal);
  572.             DDB.HandleType := bmDDB;
  573.             if NumGlyphs > 1 then
  574.             with TmpImage.Canvas do
  575.             begin    { Change white & gray to clBtnHighlight and clBtnShadow }
  576.               CopyRect(IRect, DDB.Canvas, ORect);
  577.               MonoBmp.Monochrome := True;
  578.               MonoBmp.Width := IWidth;
  579.               MonoBmp.Height := IHeight;
  580.     
  581.               { Convert white to clBtnHighlight }
  582.               DDB.Canvas.Brush.Color := clWhite;
  583.               MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
  584.               Brush.Color := clBtnHighlight;
  585.               DestDC := Handle;
  586.               SetTextColor(DestDC, clBlack);
  587.               SetBkColor(DestDC, clWhite);
  588.               BitBlt(DestDC, 0, 0, IWidth, IHeight,
  589.                      MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  590.     
  591.               { Convert gray to clBtnShadow }
  592.               DDB.Canvas.Brush.Color := clGray;
  593.               MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
  594.               Brush.Color := clBtnShadow;
  595.               DestDC := Handle;
  596.               SetTextColor(DestDC, clBlack);
  597.               SetBkColor(DestDC, clWhite);
  598.               BitBlt(DestDC, 0, 0, IWidth, IHeight,
  599.                      MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  600.     
  601.               { Convert transparent color to clBtnFace }
  602.               DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);
  603.               MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
  604.               Brush.Color := clBtnFace;
  605.               DestDC := Handle;
  606.               SetTextColor(DestDC, clBlack);
  607.               SetBkColor(DestDC, clWhite);
  608.               BitBlt(DestDC, 0, 0, IWidth, IHeight,
  609.                      MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  610.             end
  611.             else
  612.             begin
  613.               { Create a disabled version }
  614.               with MonoBmp do
  615.               begin
  616.                 Assign(FOriginal);
  617.                 HandleType := bmDDB;
  618.                 Canvas.Brush.Color := clBlack;
  619.                 Width := IWidth;
  620.                 if Monochrome then
  621.                 begin
  622.                   Canvas.Font.Color := clWhite;
  623.                   Monochrome := False;
  624.                   Canvas.Brush.Color := clWhite;
  625.                 end;
  626.                 Monochrome := True;
  627.               end;
  628.               with TmpImage.Canvas do
  629.               begin
  630.                 Brush.Color := clBtnFace;
  631.                 FillRect(IRect);
  632.                 Brush.Color := clBtnHighlight;
  633.                 SetTextColor(Handle, clBlack);
  634.                 SetBkColor(Handle, clWhite);
  635.                 BitBlt(Handle, 1, 1, IWidth, IHeight,
  636.                   MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  637.                 Brush.Color := clBtnShadow;
  638.                 SetTextColor(Handle, clBlack);
  639.                 SetBkColor(Handle, clWhite);
  640.                 BitBlt(Handle, 0, 0, IWidth, IHeight,
  641.                   MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
  642.               end;
  643.             end;
  644.           finally
  645.             DDB.Free;
  646.             MonoBmp.Free;
  647.           end;
  648.           FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
  649.         end;
  650.     end;
  651.   finally
  652.     TmpImage.Free;
  653.   end;
  654.   Result := FIndexs[State];
  655.   FOriginal.Dormant;
  656. end;
  657.     
  658. procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
  659.   State: TButtonState; Transparent: Boolean);
  660. var
  661.   Index: Integer;
  662. begin
  663.   if FOriginal = nil then Exit;
  664.   if (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit;
  665.   Index := CreateButtonGlyph(State);
  666.   with GlyphPos do
  667.     if Transparent or (State = bsExclusive) then
  668.       ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
  669.         clNone, clNone, ILD_Transparent)
  670.     else
  671.       ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
  672.         ColorToRGB(clBtnFace), clNone, ILD_Normal);
  673. end;
  674.     
  675. procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
  676.   TextBounds: TRect; State: TButtonState; BiDiFlags: LongInt);
  677. begin
  678.   with Canvas do
  679.   begin
  680.     Brush.Style := bsClear;
  681.     if State = bsDisabled then
  682.     begin
  683.       OffsetRect(TextBounds, 1, 1);
  684.       Font.Color := clBtnHighlight;
  685.       DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
  686.         DT_CENTER or DT_VCENTER or BiDiFlags);
  687.       OffsetRect(TextBounds, -1, -1);
  688.       Font.Color := clBtnShadow;
  689.       DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
  690.         DT_CENTER or DT_VCENTER or BiDiFlags);
  691.     end else
  692.       DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
  693.         DT_CENTER or DT_VCENTER or BiDiFlags);
  694.   end;
  695. end;
  696.     
  697. procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
  698.   const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,
  699.   Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
  700.   BiDiFlags: LongInt);
  701. var
  702.   TextPos: TPoint;
  703.   ClientSize, GlyphSize, TextSize: TPoint;
  704.   TotalSize: TPoint;
  705. begin
  706.   if (BiDiFlags and DT_RIGHT) = DT_RIGHT then
  707.     if Layout = blGlyphLeft then Layout := blGlyphRight
  708.     else 
  709.       if Layout = blGlyphRight then Layout := blGlyphLeft;
  710.   { calculate the item sizes }
  711.   ClientSize := Point(Client.Right - Client.Left, Client.Bottom -
  712.     Client.Top);
  713.     
  714.   if FOriginal <> nil then
  715.     GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height) else
  716.     GlyphSize := Point(0, 0);
  717.     
  718.   if Length(Caption) > 0 then
  719.   begin
  720.     TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
  721.     DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds,
  722.       DT_CALCRECT or BiDiFlags);
  723.     TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
  724.       TextBounds.Top);
  725.   end
  726.   else
  727.   begin
  728.     TextBounds := Rect(0, 0, 0, 0);
  729.     TextSize := Point(0,0);
  730.   end;
  731.     
  732.   { If the layout has the glyph on the right or the left, then both the
  733.     text and the glyph are centered vertically.  If the glyph is on the top
  734.     or the bottom, then both the text and the glyph are centered horizontally.}
  735.   if Layout in [blGlyphLeft, blGlyphRight] then
  736.   begin
  737.     GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
  738.     TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  739.   end
  740.   else
  741.   begin
  742.     GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
  743.     TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
  744.   end;
  745.     
  746.   { if there is no text or no bitmap, then Spacing is irrelevant }
  747.   if (TextSize.X = 0) or (GlyphSize.X = 0) then
  748.     Spacing := 0;
  749.     
  750.   { adjust Margin and Spacing }
  751.   if Margin = -1 then
  752.   begin
  753.     if Spacing = -1 then
  754.     begin
  755.       TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
  756.       if Layout in [blGlyphLeft, blGlyphRight] then
  757.         Margin := (ClientSize.X - TotalSize.X) div 3
  758.       else
  759.         Margin := (ClientSize.Y - TotalSize.Y) div 3;
  760.       Spacing := Margin;
  761.     end
  762.     else
  763.     begin
  764.       TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y +
  765.         Spacing + TextSize.Y);
  766.       if Layout in [blGlyphLeft, blGlyphRight] then
  767.         Margin := (ClientSize.X - TotalSize.X + 1) div 2
  768.       else
  769.         Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
  770.     end;
  771.   end
  772.   else
  773.   begin
  774.     if Spacing = -1 then
  775.     begin
  776.       TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -
  777.         (Margin + GlyphSize.Y));
  778.       if Layout in [blGlyphLeft, blGlyphRight] then
  779.         Spacing := (TotalSize.X - TextSize.X) div 2
  780.       else
  781.         Spacing := (TotalSize.Y - TextSize.Y) div 2;
  782.     end;
  783.   end;
  784.     
  785.   case Layout of
  786.     blGlyphLeft:
  787.       begin
  788.         GlyphPos.X := Margin;
  789.         TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
  790.       end;
  791.     blGlyphRight:
  792.       begin
  793.         GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
  794.         TextPos.X := GlyphPos.X - Spacing - TextSize.X;
  795.       end;
  796.     blGlyphTop:
  797.       begin
  798.         GlyphPos.Y := Margin;
  799.         TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
  800.       end;
  801.     blGlyphBottom:
  802.       begin
  803.         GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
  804.         TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
  805.       end;
  806.   end;
  807.     
  808.   { fixup the result variables }
  809.   with GlyphPos do
  810.   begin
  811.     Inc(X, Client.Left + Offset.X);
  812.     Inc(Y, Client.Top + Offset.Y);
  813.   end;
  814.   OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X,
  815.     TextPos.Y + Client.Top + Offset.X);
  816. end;
  817.     
  818. function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
  819.   const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
  820.   Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean;
  821.   BiDiFlags: LongInt): TRect;
  822. var
  823.   GlyphPos: TPoint;
  824. begin
  825.   CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
  826.     GlyphPos, Result, BiDiFlags);
  827.   DrawButtonGlyph(Canvas, GlyphPos, State, Transparent);
  828.   DrawButtonText(Canvas, Caption, Result, State, BiDiFlags);
  829. end;
  830.     
  831. { TSpeedButton }
  832.     
  833. constructor TSpeedButton.Create(AOwner: TComponent);
  834. begin
  835.   FGlyph := TButtonGlyph.Create;
  836.   TButtonGlyph(FGlyph).OnChange := GlyphChanged;
  837.   inherited Create(AOwner);
  838.   SetBounds(0, 0, 23, 22);
  839.   ControlStyle := [csCaptureMouse, csDoubleClicks];
  840.   ParentFont := True;
  841.   Color := clBtnFace;
  842.   FSpacing := 4;
  843.   FMargin := -1;
  844.   FLayout := blGlyphLeft;
  845.   FTransparent := True;
  846.   Inc(ButtonCount);
  847. end;
  848.     
  849. destructor TSpeedButton.Destroy;
  850. begin
  851.   Dec(ButtonCount);
  852.   inherited Destroy;
  853.   TButtonGlyph(FGlyph).Free;
  854. end;
  855.     
  856. procedure TSpeedButton.Paint;
  857. const
  858.   DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);
  859.   FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0);
  860. var
  861.   PaintRect: TRect;
  862.   DrawFlags: Integer;
  863.   Offset: TPoint;
  864. begin
  865.   if not Enabled then
  866.   begin
  867.     FState := bsDisabled;
  868.     FDragging := False;
  869.   end
  870.   else if FState = bsDisabled then
  871.     if FDown and (GroupIndex <> 0) then
  872.       FState := bsExclusive
  873.     else
  874.       FState := bsUp;
  875.   Canvas.Font := Self.Font;
  876.   PaintRect := Rect(0, 0, Width, Height);
  877.   if not FFlat then
  878.   begin
  879.     DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
  880.     if FState in [bsDown, bsExclusive] then
  881.       DrawFlags := DrawFlags or DFCS_PUSHED;
  882.     DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);
  883.   end
  884.   else
  885.   begin
  886.     if (FState in [bsDown, bsExclusive]) or
  887.       (FMouseInControl and (FState <> bsDisabled)) or
  888.       (csDesigning in ComponentState) then
  889.       DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]],
  890.         FillStyles[Transparent] or BF_RECT)
  891.     else if not Transparent then
  892.     begin
  893.       Canvas.Brush.Color := Color;
  894.       Canvas.FillRect(PaintRect);
  895.     end;
  896.     InflateRect(PaintRect, -1, -1);
  897.   end;
  898.   if FState in [bsDown, bsExclusive] then
  899.   begin
  900.     if (FState = bsExclusive) and (not FFlat or not FMouseInControl) then
  901.     begin
  902.       Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
  903.       Canvas.FillRect(PaintRect);
  904.     end;
  905.     Offset.X := 1;
  906.     Offset.Y := 1;
  907.   end
  908.   else
  909.   begin
  910.     Offset.X := 0;
  911.     Offset.Y := 0;
  912.   end;
  913.   TButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin,
  914.     FSpacing, FState, Transparent, DrawTextBiDiModeFlags(0));
  915. end;
  916.     
  917. procedure TSpeedButton.UpdateTracking;
  918. var
  919.   P: TPoint;
  920. begin
  921.   if FFlat then
  922.   begin
  923.     if Enabled then
  924.     begin
  925.       GetCursorPos(P);
  926.       FMouseInControl := not (FindDragTarget(P, True) = Self);
  927.       if FMouseInControl then
  928.         Perform(CM_MOUSELEAVE, 0, 0)
  929.       else
  930.         Perform(CM_MOUSEENTER, 0, 0);
  931.     end;
  932.   end;
  933. end;
  934.     
  935. procedure TSpeedButton.Loaded;
  936. var
  937.   State: TButtonState;
  938. begin
  939.   inherited Loaded;
  940.   if Enabled then
  941.     State := bsUp
  942.   else
  943.     State := bsDisabled;
  944.   TButtonGlyph(FGlyph).CreateButtonGlyph(State);
  945. end;
  946.     
  947. procedure TSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  948.   X, Y: Integer);
  949. begin
  950.   inherited MouseDown(Button, Shift, X, Y);
  951.   if (Button = mbLeft) and Enabled then
  952.   begin
  953.     if not FDown then
  954.     begin
  955.       FState := bsDown;
  956.       Invalidate;
  957.     end;
  958.     FDragging := True;
  959.   end;
  960. end;
  961.     
  962. procedure TSpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  963. var
  964.   NewState: TButtonState;
  965. begin
  966.   inherited MouseMove(Shift, X, Y);
  967.   if FDragging then
  968.   begin
  969.     if not FDown then NewState := bsUp
  970.     else NewState := bsExclusive;
  971.     if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
  972.       if FDown then NewState := bsExclusive else NewState := bsDown;
  973.     if NewState <> FState then
  974.     begin
  975.       FState := NewState;
  976.       Invalidate;
  977.     end;
  978.   end
  979.   else if not FMouseInControl then
  980.     UpdateTracking;
  981. end;
  982.     
  983. procedure TSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  984.   X, Y: Integer);
  985. var
  986.   DoClick: Boolean;
  987. begin
  988.   inherited MouseUp(Button, Shift, X, Y);
  989.   if FDragging then
  990.   begin
  991.     FDragging := False;
  992.     DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
  993.     if FGroupIndex = 0 then
  994.     begin
  995.       { Redraw face in-case mouse is captured }
  996.       FState := bsUp;
  997.       FMouseInControl := False;
  998.       if DoClick and not (FState in [bsExclusive, bsDown]) then
  999.         Invalidate;
  1000.     end
  1001.     else
  1002.       if DoClick then
  1003.       begin
  1004.         SetDown(not FDown);
  1005.         if FDown then Repaint;
  1006.       end
  1007.       else
  1008.       begin
  1009.         if FDown then FState := bsExclusive;
  1010.         Repaint;
  1011.       end;
  1012.     if DoClick then Click;
  1013.     UpdateTracking;
  1014.   end;
  1015. end;
  1016.     
  1017. procedure TSpeedButton.Click;
  1018. begin
  1019.   inherited Click;
  1020. end;
  1021.     
  1022. function TSpeedButton.GetPalette: HPALETTE;
  1023. begin
  1024.   Result := Glyph.Palette;
  1025. end;
  1026.     
  1027. function TSpeedButton.GetGlyph: TBitmap;
  1028. begin
  1029.   Result := TButtonGlyph(FGlyph).Glyph;
  1030. end;
  1031.     
  1032. procedure TSpeedButton.SetGlyph(Value: TBitmap);
  1033. begin
  1034.   TButtonGlyph(FGlyph).Glyph := Value;
  1035.   Invalidate;
  1036. end;
  1037.     
  1038. function TSpeedButton.GetNumGlyphs: TNumGlyphs;
  1039. begin
  1040.   Result := TButtonGlyph(FGlyph).NumGlyphs;
  1041. end;
  1042.     
  1043. procedure TSpeedButton.SetNumGlyphs(Value: TNumGlyphs);
  1044. begin
  1045.   if Value < 0 then Value := 1
  1046.   else if Value > 4 then Value := 4;
  1047.   if Value <> TButtonGlyph(FGlyph).NumGlyphs then
  1048.   begin
  1049.     TButtonGlyph(FGlyph).NumGlyphs := Value;
  1050.     Invalidate;
  1051.   end;
  1052. end;
  1053.     
  1054. procedure TSpeedButton.GlyphChanged(Sender: TObject);
  1055. begin
  1056.   Invalidate;
  1057. end;
  1058.     
  1059. procedure TSpeedButton.UpdateExclusive;
  1060. var
  1061.   Msg: TMessage;
  1062. begin
  1063.   if (FGroupIndex <> 0) and (Parent <> nil) then
  1064.   begin
  1065.     Msg.Msg := CM_BUTTONPRESSED;
  1066.     Msg.WParam := FGroupIndex;
  1067.     Msg.LParam := Longint(Self);
  1068.     Msg.Result := 0;
  1069.     Parent.Broadcast(Msg);
  1070.   end;
  1071. end;
  1072.     
  1073. procedure TSpeedButton.SetDown(Value: Boolean);
  1074. begin
  1075.   if FGroupIndex = 0 then Value := False;
  1076.   if Value <> FDown then
  1077.   begin
  1078.     if FDown and (not FAllowAllUp) then Exit;
  1079.     FDown := Value;
  1080.     if Value then
  1081.     begin
  1082.       if FState = bsUp then Invalidate;
  1083.       FState := bsExclusive
  1084.     end
  1085.     else
  1086.     begin
  1087.       FState := bsUp;
  1088.       Repaint;
  1089.     end;
  1090.     if Value then UpdateExclusive;
  1091.   end;
  1092. end;
  1093.     
  1094. procedure TSpeedButton.SetFlat(Value: Boolean);
  1095. begin
  1096.   if Value <> FFlat then
  1097.   begin
  1098.     FFlat := Value;
  1099.     Invalidate;
  1100.   end;
  1101. end;
  1102.     
  1103. procedure TSpeedButton.SetGroupIndex(Value: Integer);
  1104. begin
  1105.   if FGroupIndex <> Value then
  1106.   begin
  1107.     FGroupIndex := Value;
  1108.     UpdateExclusive;
  1109.   end;
  1110. end;
  1111.     
  1112. procedure TSpeedButton.SetLayout(Value: TButtonLayout);
  1113. begin
  1114.   if FLayout <> Value then
  1115.   begin
  1116.     FLayout := Value;
  1117.     Invalidate;
  1118.   end;
  1119. end;
  1120.     
  1121. procedure TSpeedButton.SetMargin(Value: Integer);
  1122. begin
  1123.   if (Value <> FMargin) and (Value >= -1) then
  1124.   begin
  1125.     FMargin := Value;
  1126.     Invalidate;
  1127.   end;
  1128. end;
  1129.     
  1130. procedure TSpeedButton.SetSpacing(Value: Integer);
  1131. begin
  1132.   if Value <> FSpacing then
  1133.   begin
  1134.     FSpacing := Value;
  1135.     Invalidate;
  1136.   end;
  1137. end;
  1138.  
  1139. procedure TSpeedButton.SetTransparent(Value: Boolean);
  1140. begin
  1141.   if Value <> FTransparent then
  1142.   begin
  1143.     FTransparent := Value;
  1144.     if Value then
  1145.       ControlStyle := ControlStyle - [csOpaque] else
  1146.       ControlStyle := ControlStyle + [csOpaque];
  1147.     Invalidate;
  1148.   end;
  1149. end;
  1150.  
  1151. procedure TSpeedButton.SetAllowAllUp(Value: Boolean);
  1152. begin
  1153.   if FAllowAllUp <> Value then
  1154.   begin
  1155.     FAllowAllUp := Value;
  1156.     UpdateExclusive;
  1157.   end;
  1158. end;
  1159.     
  1160. procedure TSpeedButton.WMLButtonDblClk(var Message: TWMLButtonDown);
  1161. begin
  1162.   inherited;
  1163.   if FDown then DblClick;
  1164. end;
  1165.     
  1166. procedure TSpeedButton.CMEnabledChanged(var Message: TMessage);
  1167. const
  1168.   NewState: array[Boolean] of TButtonState = (bsDisabled, bsUp);
  1169. begin
  1170.   TButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);
  1171.   UpdateTracking;
  1172.   Repaint;
  1173. end;
  1174.     
  1175. procedure TSpeedButton.CMButtonPressed(var Message: TMessage);
  1176. var
  1177.   Sender: TSpeedButton;
  1178. begin
  1179.   if Message.WParam = FGroupIndex then
  1180.   begin
  1181.     Sender := TSpeedButton(Message.LParam);
  1182.     if Sender <> Self then
  1183.     begin
  1184.       if Sender.Down and FDown then
  1185.       begin
  1186.         FDown := False;
  1187.         FState := bsUp;
  1188.         Invalidate;
  1189.       end;
  1190.       FAllowAllUp := Sender.AllowAllUp;
  1191.     end;
  1192.   end;
  1193. end;
  1194.     
  1195. procedure TSpeedButton.CMDialogChar(var Message: TCMDialogChar);
  1196. begin
  1197.   with Message do
  1198.     if IsAccel(CharCode, Caption) and Enabled and Visible and
  1199.       (Parent <> nil) and Parent.Showing then
  1200.     begin
  1201.       Click;
  1202.       Result := 1;
  1203.     end else
  1204.       inherited;
  1205. end;
  1206.     
  1207. procedure TSpeedButton.CMFontChanged(var Message: TMessage);
  1208. begin
  1209.   Invalidate;
  1210. end;
  1211.     
  1212. procedure TSpeedButton.CMTextChanged(var Message: TMessage);
  1213. begin
  1214.   Invalidate;
  1215. end;
  1216.     
  1217. procedure TSpeedButton.CMSysColorChange(var Message: TMessage);
  1218. begin
  1219.   with TButtonGlyph(FGlyph) do
  1220.   begin
  1221.     Invalidate;
  1222.     CreateButtonGlyph(FState);
  1223.   end;
  1224. end;
  1225.     
  1226. procedure TSpeedButton.CMMouseEnter(var Message: TMessage);
  1227. begin
  1228.   inherited;
  1229.   { Don't draw a border if DragMode <> dmAutomatic since this button is meant to 
  1230.     be used as a dock client. }
  1231.   if FFlat and not FMouseInControl and Enabled and (DragMode <> dmAutomatic) 
  1232.     and (GetCapture = 0) then
  1233.   begin
  1234.     FMouseInControl := True;
  1235.     Repaint;
  1236.   end;
  1237. end;
  1238.  
  1239. procedure TSpeedButton.CMMouseLeave(var Message: TMessage);
  1240. begin
  1241.   inherited;
  1242.   if FFlat and FMouseInControl and Enabled and not FDragging then
  1243.   begin
  1244.     FMouseInControl := False;
  1245.     Invalidate;
  1246.   end;
  1247. end;
  1248.  
  1249. procedure TSpeedButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);
  1250.  
  1251.   procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
  1252.   begin
  1253.     with Glyph do
  1254.     begin
  1255.       Width := ImageList.Width;
  1256.       Height := ImageList.Height;
  1257.       Canvas.Brush.Color := clFuchsia;//! for lack of a better color
  1258.       Canvas.FillRect(Rect(0,0, Width, Height));
  1259.       ImageList.Draw(Canvas, 0, 0, Index);
  1260.     end;
  1261.   end;
  1262.  
  1263. begin
  1264.   inherited ActionChange(Sender, CheckDefaults);
  1265.   if Sender is TCustomAction then
  1266.     with TCustomAction(Sender) do
  1267.     begin
  1268.       { Copy image from action's imagelist }
  1269.       if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
  1270.         (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
  1271.         CopyImage(ActionList.Images, ImageIndex);
  1272.     end;
  1273. end;
  1274.  
  1275. { TBitBtn }
  1276.     
  1277. constructor TBitBtn.Create(AOwner: TComponent);
  1278. begin
  1279.   FGlyph := TButtonGlyph.Create;
  1280.   TButtonGlyph(FGlyph).OnChange := GlyphChanged;
  1281.   inherited Create(AOwner);
  1282.   FCanvas := TCanvas.Create;
  1283.   FStyle := bsAutoDetect;
  1284.   FKind := bkCustom;
  1285.   FLayout := blGlyphLeft;
  1286.   FSpacing := 4;
  1287.   FMargin := -1;
  1288.   ControlStyle := ControlStyle + [csReflector];
  1289. end;
  1290.     
  1291. destructor TBitBtn.Destroy;
  1292. begin
  1293.   inherited Destroy;
  1294.   TButtonGlyph(FGlyph).Free;
  1295.   FCanvas.Free;
  1296. end;
  1297.     
  1298. procedure TBitBtn.CreateHandle;
  1299. var
  1300.   State: TButtonState;
  1301. begin
  1302.   if Enabled then
  1303.     State := bsUp
  1304.   else
  1305.     State := bsDisabled;
  1306.   inherited CreateHandle;
  1307.   TButtonGlyph(FGlyph).CreateButtonGlyph(State);
  1308. end;
  1309.     
  1310. procedure TBitBtn.CreateParams(var Params: TCreateParams);
  1311. begin
  1312.   inherited CreateParams(Params);
  1313.   with Params do Style := Style or BS_OWNERDRAW;
  1314. end;
  1315.     
  1316. procedure TBitBtn.SetButtonStyle(ADefault: Boolean);
  1317. begin
  1318.   if ADefault <> IsFocused then
  1319.   begin
  1320.     IsFocused := ADefault;
  1321.     Refresh;
  1322.   end;
  1323. end;
  1324.     
  1325. procedure TBitBtn.Click;
  1326. var
  1327.   Form: TCustomForm;
  1328.   Control: TWinControl;
  1329. begin
  1330.   case FKind of
  1331.     bkClose:
  1332.       begin
  1333.         Form := GetParentForm(Self);
  1334.         if Form <> nil then Form.Close
  1335.         else inherited Click;
  1336.       end;
  1337.     bkHelp:
  1338.       begin
  1339.         Control := Self;
  1340.         while (Control <> nil) and (Control.HelpContext = 0) do
  1341.           Control := Control.Parent;
  1342.         if Control <> nil then Application.HelpContext(Control.HelpContext)
  1343.         else inherited Click;
  1344.       end;
  1345.     else
  1346.       inherited Click;
  1347.   end;
  1348. end;
  1349.     
  1350. procedure TBitBtn.CNMeasureItem(var Message: TWMMeasureItem);
  1351. begin
  1352.   with Message.MeasureItemStruct^ do
  1353.   begin
  1354.     itemWidth := Width;
  1355.     itemHeight := Height;
  1356.   end;
  1357. end;
  1358.     
  1359. procedure TBitBtn.CNDrawItem(var Message: TWMDrawItem);
  1360. begin
  1361.   DrawItem(Message.DrawItemStruct^);
  1362. end;
  1363.     
  1364. procedure TBitBtn.DrawItem(const DrawItemStruct: TDrawItemStruct);
  1365. var
  1366.   IsDown, IsDefault: Boolean;
  1367.   State: TButtonState;
  1368.   R: TRect;
  1369.   Flags: Longint;
  1370. begin
  1371.   FCanvas.Handle := DrawItemStruct.hDC;
  1372.   R := ClientRect;
  1373.     
  1374.   with DrawItemStruct do
  1375.   begin
  1376.     IsDown := itemState and ODS_SELECTED <> 0;
  1377.     IsDefault := itemState and ODS_FOCUS <> 0;
  1378.     
  1379.     if not Enabled then State := bsDisabled
  1380.     else if IsDown then State := bsDown
  1381.     else State := bsUp;
  1382.   end;
  1383.     
  1384.   Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
  1385.   if IsDown then Flags := Flags or DFCS_PUSHED;
  1386.   if DrawItemStruct.itemState and ODS_DISABLED <> 0 then
  1387.     Flags := Flags or DFCS_INACTIVE;
  1388.     
  1389.   { DrawFrameControl doesn't allow for drawing a button as the
  1390.       default button, so it must be done here. }
  1391.   if IsFocused or IsDefault then
  1392.   begin
  1393.     FCanvas.Pen.Color := clWindowFrame;
  1394.     FCanvas.Pen.Width := 1;
  1395.     FCanvas.Brush.Style := bsClear;
  1396.     FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  1397.     
  1398.     { DrawFrameControl must draw within this border }
  1399.     InflateRect(R, -1, -1);
  1400.   end;
  1401.     
  1402.   { DrawFrameControl does not draw a pressed button correctly }
  1403.   if IsDown then
  1404.   begin
  1405.     FCanvas.Pen.Color := clBtnShadow;
  1406.     FCanvas.Pen.Width := 1;
  1407.     FCanvas.Brush.Color := clBtnFace;
  1408.     FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  1409.     InflateRect(R, -1, -1);
  1410.   end
  1411.   else
  1412.     DrawFrameControl(DrawItemStruct.hDC, R, DFC_BUTTON, Flags);
  1413.     
  1414.   if IsFocused then
  1415.   begin
  1416.     R := ClientRect;
  1417.     InflateRect(R, -1, -1);
  1418.   end;
  1419.     
  1420.   FCanvas.Font := Self.Font;
  1421.   if IsDown then
  1422.     OffsetRect(R, 1, 1);
  1423.   TButtonGlyph(FGlyph).Draw(FCanvas, R, Point(0,0), Caption, FLayout, FMargin,
  1424.     FSpacing, State, False, DrawTextBiDiModeFlags(0));
  1425.     
  1426.   if IsFocused and IsDefault then
  1427.   begin
  1428.     R := ClientRect;
  1429.     InflateRect(R, -4, -4);
  1430.     FCanvas.Pen.Color := clWindowFrame;
  1431.     FCanvas.Brush.Color := clBtnFace;
  1432.     DrawFocusRect(FCanvas.Handle, R);
  1433.   end;
  1434.     
  1435.   FCanvas.Handle := 0;
  1436. end;
  1437.     
  1438. procedure TBitBtn.CMFontChanged(var Message: TMessage);
  1439. begin
  1440.   inherited;
  1441.   Invalidate;
  1442. end;
  1443.     
  1444. procedure TBitBtn.CMEnabledChanged(var Message: TMessage);
  1445. begin
  1446.   inherited;
  1447.   Invalidate;
  1448. end;
  1449.     
  1450. procedure TBitBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  1451. begin
  1452.   Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
  1453. end;
  1454.     
  1455. function TBitBtn.GetPalette: HPALETTE;
  1456. begin
  1457.   Result := Glyph.Palette;
  1458. end;
  1459.     
  1460. procedure TBitBtn.SetGlyph(Value: TBitmap);
  1461. begin
  1462.   TButtonGlyph(FGlyph).Glyph := Value as TBitmap;
  1463.   FModifiedGlyph := True;
  1464.   Invalidate;
  1465. end;
  1466.     
  1467. function TBitBtn.GetGlyph: TBitmap;
  1468. begin
  1469.   Result := TButtonGlyph(FGlyph).Glyph;
  1470. end;
  1471.     
  1472. procedure TBitBtn.GlyphChanged(Sender: TObject);
  1473. begin
  1474.   Invalidate;
  1475. end;
  1476.     
  1477. function TBitBtn.IsCustom: Boolean;
  1478. begin
  1479.   Result := Kind = bkCustom;
  1480. end;
  1481.     
  1482. procedure TBitBtn.SetStyle(Value: TButtonStyle);
  1483. begin
  1484.   if Value <> FStyle then
  1485.   begin
  1486.     FStyle := Value;
  1487.     Invalidate;
  1488.   end;
  1489. end;
  1490.     
  1491. procedure TBitBtn.SetKind(Value: TBitBtnKind);
  1492. begin
  1493.   if Value <> FKind then
  1494.   begin
  1495.     if Value <> bkCustom then
  1496.     begin
  1497.       Default := Value in [bkOK, bkYes];
  1498.       Cancel := Value in [bkCancel, bkNo];
  1499.     
  1500.       if ((csLoading in ComponentState) and (Caption = '')) or
  1501.         (not (csLoading in ComponentState)) then
  1502.       begin
  1503.         if BitBtnCaptions[Value] <> nil then
  1504.           Caption := LoadResString(BitBtnCaptions[Value]);
  1505.       end;
  1506.     
  1507.       ModalResult := BitBtnModalResults[Value];
  1508.       TButtonGlyph(FGlyph).Glyph := GetBitBtnGlyph(Value);
  1509.       NumGlyphs := 2;
  1510.       FModifiedGlyph := False;
  1511.     end;
  1512.     FKind := Value;
  1513.     Invalidate;
  1514.   end;
  1515. end;
  1516.     
  1517. function TBitBtn.IsCustomCaption: Boolean;
  1518. begin
  1519.   Result := AnsiCompareStr(Caption, LoadResString(BitBtnCaptions[FKind])) <> 0;
  1520. end;
  1521.     
  1522. function TBitBtn.GetKind: TBitBtnKind;
  1523. begin
  1524.   if FKind <> bkCustom then
  1525.     if ((FKind in [bkOK, bkYes]) xor Default) or
  1526.       ((FKind in [bkCancel, bkNo]) xor Cancel) or
  1527.       (ModalResult <> BitBtnModalResults[FKind]) or
  1528.       FModifiedGlyph then
  1529.       FKind := bkCustom;
  1530.   Result := FKind;
  1531. end;
  1532.     
  1533. procedure TBitBtn.SetLayout(Value: TButtonLayout);
  1534. begin
  1535.   if FLayout <> Value then
  1536.   begin
  1537.     FLayout := Value;
  1538.     Invalidate;
  1539.   end;
  1540. end;
  1541.     
  1542. function TBitBtn.GetNumGlyphs: TNumGlyphs;
  1543. begin
  1544.   Result := TButtonGlyph(FGlyph).NumGlyphs;
  1545. end;
  1546.     
  1547. procedure TBitBtn.SetNumGlyphs(Value: TNumGlyphs);
  1548. begin
  1549.   if Value < 0 then Value := 1
  1550.   else if Value > 4 then Value := 4;
  1551.   if Value <> TButtonGlyph(FGlyph).NumGlyphs then
  1552.   begin
  1553.     TButtonGlyph(FGlyph).NumGlyphs := Value;
  1554.     Invalidate;
  1555.   end;
  1556. end;
  1557.     
  1558. procedure TBitBtn.SetSpacing(Value: Integer);
  1559. begin
  1560.   if FSpacing <> Value then
  1561.   begin
  1562.     FSpacing := Value;
  1563.     Invalidate;
  1564.   end;
  1565. end;
  1566.     
  1567. procedure TBitBtn.SetMargin(Value: Integer);
  1568. begin
  1569.   if (Value <> FMargin) and (Value >= - 1) then
  1570.   begin
  1571.     FMargin := Value;
  1572.     Invalidate;
  1573.   end;
  1574. end;
  1575.  
  1576. procedure TBitBtn.ActionChange(Sender: TObject; CheckDefaults: Boolean);
  1577.  
  1578.   procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
  1579.   begin
  1580.     with Glyph do
  1581.     begin
  1582.       Width := ImageList.Width;
  1583.       Height := ImageList.Height;
  1584.       Canvas.Brush.Color := clFuchsia;//! for lack of a better color
  1585.       Canvas.FillRect(Rect(0,0, Width, Height));
  1586.       ImageList.Draw(Canvas, 0, 0, Index);
  1587.     end;
  1588.   end;
  1589.  
  1590. begin
  1591.   inherited ActionChange(Sender, CheckDefaults);
  1592.   if Sender is TCustomAction then
  1593.     with TCustomAction(Sender) do
  1594.     begin
  1595.       { Copy image from action's imagelist }
  1596.       if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
  1597.         (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
  1598.         CopyImage(ActionList.Images, ImageIndex);
  1599.     end;
  1600. end;
  1601.  
  1602. procedure DestroyLocals; far;
  1603. var
  1604.   I: TBitBtnKind;
  1605. begin
  1606.   for I := Low(TBitBtnKind) to High(TBitBtnKind) do
  1607.     BitBtnGlyphs[I].Free;
  1608. end;
  1609.     
  1610. initialization
  1611.   FillChar(BitBtnGlyphs, SizeOf(BitBtnGlyphs), 0);
  1612. finalization
  1613.   DestroyLocals;
  1614. end.
  1615.