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