home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kompon / d23456 / TB97.ZIP / Source / TB97Ctls.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-06-18  |  92.5 KB  |  2,943 lines
  1. unit TB97Ctls;
  2.  
  3. {
  4.   Toolbar97
  5.   Copyright (C) 1998-2001 by Jordan Russell
  6.   For conditions of distribution and use, see LICENSE.TXT.
  7.  
  8.   TToolbarButton97 & TEdit97
  9.  
  10.   $Id: TB97Ctls.pas,v 1.8 2001/05/01 17:00:49 jr Exp $
  11. }
  12.  
  13. interface
  14.  
  15. {$I TB97Ver.inc}
  16.  
  17. uses
  18.   Windows, Messages, Classes, Controls, Forms, Menus, Graphics, Buttons,
  19.   {$IFDEF TB97D4} ImgList, ActnList, {$ENDIF} StdCtrls, ExtCtrls,
  20.   TB97Vers;
  21.  
  22. const
  23.   DefaultDropdownArrowWidth = 9;
  24. type
  25.   { TToolbarButton97 }
  26.  
  27.   TButtonDisplayMode = (dmBoth, dmGlyphOnly, dmTextOnly);
  28.   TButtonState97 = (bsUp, bsDisabled, bsDown, bsExclusive, bsMouseIn);
  29.   TNumGlyphs97 = 1..5;
  30.   TButtonDropdownEvent = procedure(Sender: TObject;
  31.     var ShowMenu, RemoveClicks: Boolean) of object;
  32.  
  33.   TToolbarButton97 = class(TGraphicControl)
  34.   private
  35.     FAllowAllUp: Boolean;
  36.     FAlignment: TAlignment;
  37.     FCancel: Boolean;
  38.     FDefault: Boolean;
  39.     FDisplayMode: TButtonDisplayMode;
  40.     FDown: Boolean;
  41.     FDropdownAlways: Boolean;
  42.     FDropdownArrow: Boolean;
  43.     FDropdownArrowWidth: Integer;
  44.     FDropdownCombo: Boolean;
  45.     FDropdownMenu: TPopupMenu;
  46.     FFlat: Boolean;
  47.     FGlyph: Pointer;
  48.     FGroupIndex: Integer;
  49.     FHelpContext: THelpContext;
  50.     FHighlightWhenDown: Boolean;
  51.     FLayout: TButtonLayout;
  52.     FMargin: Integer;
  53.     FModalResult: TModalResult;
  54.     FNoBorder: Boolean;
  55.     FOldDisabledStyle: Boolean;
  56.     FOpaque: Boolean;
  57.     FRepeating: Boolean;
  58.     FRepeatDelay, FRepeatInterval: Integer;
  59.     FShowBorderWhenInactive: Boolean;
  60.     FSpacing: Integer;
  61.     FWordWrap: Boolean;
  62.     FOnDropdown: TButtonDropdownEvent;
  63.     FOnMouseEnter, FOnMouseExit: TNotifyEvent;
  64.     { Internal }
  65.     FInClick: Boolean;
  66.     FMouseInControl: Boolean;
  67.     FMouseIsDown: Boolean;
  68.     FMenuIsDown: Boolean;
  69.     FUsesDropdown: Boolean;
  70.     FRepeatTimer: TTimer;
  71.     procedure GlyphChanged(Sender: TObject);
  72.     procedure UpdateExclusive;
  73.     procedure SetAlignment (Value: TAlignment);
  74.     procedure SetAllowAllUp (Value: Boolean);
  75.     function GetCallDormant: Boolean;
  76.     procedure SetCallDormant (Value: Boolean);
  77.     procedure SetDown (Value: Boolean);
  78.     procedure SetDisplayMode (Value: TButtonDisplayMode);
  79.     procedure SetDropdownAlways (Value: Boolean);
  80.     procedure SetDropdownArrow (Value: Boolean);
  81.     procedure SetDropdownArrowWidth (Value: Integer);
  82.     procedure SetDropdownCombo (Value: Boolean);
  83.     procedure SetDropdownMenu (Value: TPopupMenu);
  84.     procedure SetFlat (Value: Boolean);
  85.     function GetGlyph: TBitmap;
  86.     procedure SetGlyph (Value: TBitmap);
  87.     function GetGlyphMask: TBitmap;
  88.     procedure SetGlyphMask (Value: TBitmap);
  89.     procedure SetGroupIndex (Value: Integer);
  90.     procedure SetHighlightWhenDown (Value: Boolean);
  91.     function GetImageIndex: Integer;
  92.     procedure SetImageIndex (Value: Integer);
  93.     function GetImages: TCustomImageList;
  94.     procedure SetImages (Value: TCustomImageList);
  95.     procedure SetLayout (Value: TButtonLayout);
  96.     procedure SetMargin (Value: Integer);
  97.     procedure SetNoBorder (Value: Boolean);
  98.     function GetNumGlyphs: TNumGlyphs97;
  99.     procedure SetNumGlyphs (Value: TNumGlyphs97);
  100.     procedure SetOldDisabledStyle (Value: Boolean);
  101.     procedure SetOpaque (Value: Boolean);
  102.     procedure SetSpacing (Value: Integer);
  103.     function GetVersion: TToolbar97Version;
  104.     procedure SetVersion (const Value: TToolbar97Version);
  105.     procedure SetWordWrap (Value: Boolean);
  106.     procedure RemoveButtonMouseTimer;
  107.     procedure Redraw (const Erase: Boolean);
  108.     function PointInButton (X, Y: Integer): Boolean;
  109.     procedure ButtonMouseTimerHandler (Sender: TObject);
  110.     procedure RepeatTimerHandler (Sender: TObject);
  111.     {$IFDEF TB97D4}
  112.     function IsCheckedStored: Boolean;
  113.     function IsHelpContextStored: Boolean;
  114.     function IsImageIndexStored: Boolean;
  115.     {$ENDIF}
  116.     procedure WMLButtonDblClk (var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  117.     procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED;
  118.     procedure CMDialogChar (var Message: TCMDialogChar); message CM_DIALOGCHAR;
  119.     procedure CMDialogKey (var Message: TCMDialogKey); message CM_DIALOGKEY;
  120.     procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED;
  121.     procedure CMTextChanged (var Message: TMessage); message CM_TEXTCHANGED;
  122.     procedure CMSysColorChange (var Message: TMessage); message CM_SYSCOLORCHANGE;
  123.     procedure WMCancelMode (var Message: TWMCancelMode); message WM_CANCELMODE;
  124.   protected
  125.     FState: TButtonState97;
  126.     function GetPalette: HPALETTE; override;
  127.     procedure Loaded; override;
  128.     procedure Notification (AComponent: TComponent; Operation: TOperation); override;
  129.     procedure MouseDown (Button: TMouseButton; Shift: TShiftState;
  130.       X, Y: Integer); override;
  131.     procedure MouseMove (Shift: TShiftState; X, Y: Integer); override;
  132.     procedure MouseUp (Button: TMouseButton; Shift: TShiftState;
  133.       X, Y: Integer); override;
  134.     procedure Paint; override;
  135.     {$IFDEF TB97D4}
  136.     procedure ActionChange (Sender: TObject; CheckDefaults: Boolean); override;
  137.     function GetActionLinkClass: TControlActionLinkClass; override;
  138.     procedure AssignTo (Dest: TPersistent); override;
  139.     {$ENDIF}
  140.   public
  141.     property Canvas;
  142.     property CallDormant: Boolean read GetCallDormant write SetCallDormant;
  143.  
  144.     constructor Create(AOwner: TComponent); override;
  145.     destructor Destroy; override;
  146.     procedure Click; override;
  147.     procedure MouseEntered;
  148.     procedure MouseLeft;
  149.   published
  150.     {$IFDEF TB97D4}
  151.     property Action;
  152.     {$ENDIF}
  153.     property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;
  154.     property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
  155.     {$IFDEF TB97D4}
  156.     property Anchors;
  157.     {$ENDIF}
  158.     property Cancel: Boolean read FCancel write FCancel default False;
  159.     property Color default clBtnFace;
  160.     {$IFDEF TB97D4}
  161.     property Constraints;
  162.     {$ENDIF}
  163.     property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
  164.     property Default: Boolean read FDefault write FDefault default False;
  165.     property DisplayMode: TButtonDisplayMode read FDisplayMode write SetDisplayMode default dmBoth;
  166.     property Down: Boolean read FDown write SetDown {$IFDEF TB97D4} stored IsCheckedStored {$ENDIF} default False;
  167.     property DragCursor;
  168.     property DragMode;
  169.     property DropdownAlways: Boolean read FDropdownAlways write SetDropdownAlways default False;
  170.     property DropdownArrow: Boolean read FDropdownArrow write SetDropdownArrow default True;
  171.     property DropdownArrowWidth: Integer read FDropdownArrowWidth write SetDropdownArrowWidth default DefaultDropdownArrowWidth;
  172.     property DropdownCombo: Boolean read FDropdownCombo write SetDropdownCombo default False;
  173.     property DropdownMenu: TPopupMenu read FDropdownMenu write SetDropdownMenu;
  174.     property Caption;
  175.     property Enabled;
  176.     property Flat: Boolean read FFlat write SetFlat default True;
  177.     property Font;
  178.     property Glyph: TBitmap read GetGlyph write SetGlyph;
  179.     property GlyphMask: TBitmap read GetGlyphMask write SetGlyphMask;
  180.     property HelpContext: THelpContext read FHelpContext write FHelpContext {$IFDEF TB97D4} stored IsHelpContextStored {$ENDIF} default 0;
  181.     property HighlightWhenDown: Boolean read FHighlightWhenDown write SetHighlightWhenDown default True;
  182.     property ImageIndex: Integer read GetImageIndex write SetImageIndex {$IFDEF TB97D4} stored IsImageIndexStored {$ENDIF} default -1;
  183.     property Images: TCustomImageList read GetImages write SetImages;
  184.     property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
  185.     property Margin: Integer read FMargin write SetMargin default -1;
  186.     property ModalResult: TModalResult read FModalResult write FModalResult default 0;
  187.     property NoBorder: Boolean read FNoBorder write SetNoBorder default False;
  188.     property NumGlyphs: TNumGlyphs97 read GetNumGlyphs write SetNumGlyphs default 1;
  189.     property OldDisabledStyle: Boolean read FOldDisabledStyle write SetOldDisabledStyle default False;
  190.     property Opaque: Boolean read FOpaque write SetOpaque default True;
  191.     property ParentFont;
  192.     property ParentColor default False;
  193.     property ParentShowHint;
  194.     property Repeating: Boolean read FRepeating write FRepeating default False;
  195.     property RepeatDelay: Integer read FRepeatDelay write FRepeatDelay default 400;
  196.     property RepeatInterval: Integer read FRepeatInterval write FRepeatInterval default 100;
  197.     property ShowBorderWhenInactive: Boolean read FShowBorderWhenInactive write FShowBorderWhenInactive default False;
  198.     property ShowHint;
  199.     property Spacing: Integer read FSpacing write SetSpacing default 4;
  200.     property Version: TToolbar97Version read GetVersion write SetVersion stored False;
  201.     property Visible;
  202.     property WordWrap: Boolean read FWordWrap write SetWordWrap default False;
  203.  
  204.     property OnClick;
  205.     property OnDblClick;
  206.     property OnDragDrop;
  207.     property OnDragOver;
  208.     property OnDropdown: TButtonDropdownEvent read FOnDropdown write FOnDropdown;
  209.     property OnEndDrag;
  210.     property OnMouseDown;
  211.     property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
  212.     property OnMouseExit: TNotifyEvent read FOnMouseExit write FOnMouseExit;
  213.     property OnMouseMove;
  214.     property OnMouseUp;
  215.     property OnStartDrag;
  216.   end;
  217.  
  218.   { TToolButtonActionLink }
  219.  
  220.   {$IFDEF TB97D4}
  221.   TToolbarButton97ActionLink = class(TControlActionLink)
  222.   protected
  223.     FClient: TToolbarButton97;
  224.     procedure AssignClient (AClient: TObject); override;
  225.     function IsCheckedLinked: Boolean; override;
  226.     function IsHelpContextLinked: Boolean; override;
  227.     function IsImageIndexLinked: Boolean; override;
  228.     procedure SetChecked (Value: Boolean); override;
  229.     procedure SetHelpContext (Value: THelpContext); override;
  230.     procedure SetImageIndex (Value: Integer); override;
  231.   end;
  232.  
  233.   TToolbarButton97ActionLinkClass = class of TToolbarButton97ActionLink;
  234.   {$ENDIF}
  235.  
  236.   { TEdit97 }
  237.  
  238.   TEdit97 = class(TCustomEdit)
  239.   private
  240.     MouseInControl: Boolean;
  241.     function GetVersion: TToolbar97Version;
  242.     procedure SetVersion (const Value: TToolbar97Version);
  243.     procedure DrawNCArea (const DrawToDC: Boolean; const ADC: HDC;
  244.       const Clip: HRGN);
  245.     procedure NewAdjustHeight;
  246.     procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED;
  247.     procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED;
  248.     procedure CMMouseEnter (var Message: TMessage); message CM_MOUSEENTER;
  249.     procedure CMMouseLeave (var Message: TMessage); message CM_MOUSELEAVE;
  250.     procedure WMKillFocus (var Message: TWMKillFocus); message WM_KILLFOCUS;
  251.     procedure WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
  252.     procedure WMNCPaint (var Message: TMessage); message WM_NCPAINT;
  253.     procedure WMPrint (var Message: TMessage); message WM_PRINT;
  254.     procedure WMPrintClient (var Message: TMessage); message WM_PRINTCLIENT;
  255.     procedure WMSetFocus (var Message: TWMSetFocus); message WM_SETFOCUS;
  256.   protected
  257.     procedure Loaded; override;
  258.   public
  259.     constructor Create (AOwner: TComponent); override;
  260.     destructor Destroy; override;
  261.   published
  262.     property AutoSelect;
  263.     {$IFDEF TB97D4}
  264.     property Anchors;
  265.     {$ENDIF}
  266.     property Align;
  267.     {$IFDEF TB97D4}
  268.     property BiDiMode;
  269.     {$ENDIF}
  270.     property CharCase;
  271.     {$IFDEF TB97D4}
  272.     property Constraints;
  273.     {$ENDIF}
  274.     property DragCursor;
  275.     {$IFDEF TB97D4}
  276.     property DragKind;
  277.     {$ENDIF}
  278.     property DragMode;
  279.     property Enabled;
  280.     property Font;
  281.     property HideSelection;
  282.     {$IFDEF TB97D3}
  283.     property ImeMode;
  284.     property ImeName;
  285.     {$ENDIF}
  286.     property MaxLength;
  287.     property OEMConvert;
  288.     {$IFDEF TB97D4}
  289.     property ParentBiDiMode;
  290.     {$ENDIF}
  291.     property ParentColor;
  292.     property ParentCtl3D;
  293.     property ParentFont;
  294.     property ParentShowHint;
  295.     property PasswordChar;
  296.     property PopupMenu;
  297.     property ReadOnly;
  298.     property ShowHint;
  299.     property TabOrder;
  300.     property TabStop;
  301.     property Text;
  302.     property Version: TToolbar97Version read GetVersion write SetVersion stored False;
  303.     property Visible;
  304.     property OnChange;
  305.     property OnClick;
  306.     property OnDblClick;
  307.     property OnDragDrop;
  308.     property OnDragOver;
  309.     {$IFDEF TB97D4}
  310.     property OnEndDock;
  311.     {$ENDIF}
  312.     property OnEndDrag;
  313.     property OnEnter;
  314.     property OnExit;
  315.     property OnKeyDown;
  316.     property OnKeyPress;
  317.     property OnKeyUp;
  318.     property OnMouseDown;
  319.     property OnMouseMove;
  320.     property OnMouseUp;
  321.     {$IFDEF TB97D4}
  322.     property OnStartDock;
  323.     {$ENDIF}
  324.     property OnStartDrag;
  325.   end;
  326.  
  327. var
  328.   ButtonsStayDown: Boolean = True;
  329.   ButtonMouseInControl: TToolbarButton97 = nil;
  330.  
  331. function ControlIs97Control (AControl: TControl): Boolean;
  332. procedure Register97ControlClass (AClass: TClass);
  333. procedure Unregister97ControlClass (AClass: TClass);
  334.  
  335. implementation
  336.  
  337. uses
  338.   SysUtils, Consts, CommCtrl, TB97Cmn;
  339.  
  340. var
  341.   { See TToolbarButton97.ButtonMouseTimerHandler for info on this }
  342.   ButtonMouseTimer: TTimer = nil;
  343.  
  344.   Control97List: TList = nil;
  345.  
  346.   Edit97Count: Integer = 0;
  347.  
  348. const
  349.   DropdownComboSpace = 2;
  350.  
  351. function ControlIs97Control (AControl: TControl): Boolean;
  352. var
  353.   I: Integer;
  354. begin
  355.   Result := False;
  356.   if Assigned(AControl) and Assigned(Control97List) then
  357.     for I := 0 to Control97List.Count-1 do
  358.       if AControl is TClass(Control97List[I]) then begin
  359.         Result := True;
  360.         Break;
  361.       end;
  362. end;
  363.  
  364. procedure Register97ControlClass (AClass: TClass);
  365. begin
  366.   if Control97List = nil then Control97List := TList.Create;
  367.   Control97List.Add (AClass);
  368. end;
  369.  
  370. procedure Unregister97ControlClass (AClass: TClass);
  371. begin
  372.   if Assigned(Control97List) then begin
  373.     Control97List.Remove (AClass);
  374.     if Control97List.Count = 0 then begin
  375.       Control97List.Free;
  376.       Control97List := nil;
  377.     end;
  378.   end;
  379. end;
  380.  
  381. { TToolbarButton97ActionLink - internal }
  382.  
  383. {$IFDEF TB97D4}
  384. procedure TToolbarButton97ActionLink.AssignClient (AClient: TObject);
  385. begin
  386.   inherited AssignClient(AClient);
  387.   FClient := AClient as TToolbarButton97;
  388. end;
  389.  
  390. function TToolbarButton97ActionLink.IsCheckedLinked: Boolean;
  391. begin
  392.   Result := inherited IsCheckedLinked and
  393.     (FClient.Down = (Action as TCustomAction).Checked);
  394. end;
  395.  
  396. function TToolbarButton97ActionLink.IsHelpContextLinked: Boolean;
  397. begin
  398.   Result := inherited IsHelpContextLinked and
  399.     (FClient.HelpContext = (Action as TCustomAction).HelpContext);
  400. end;
  401.  
  402. function TToolbarButton97ActionLink.IsImageIndexLinked: Boolean;
  403. begin
  404.   Result := inherited IsImageIndexLinked and
  405.     (FClient.ImageIndex = (Action as TCustomAction).ImageIndex);
  406. end;
  407.  
  408. procedure TToolbarButton97ActionLink.SetChecked (Value: Boolean);
  409. begin
  410.   if IsCheckedLinked then FClient.Down := Value;
  411. end;
  412.  
  413. procedure TToolbarButton97ActionLink.SetHelpContext (Value: THelpContext);
  414. begin
  415.   if IsHelpContextLinked then FClient.HelpContext := Value;
  416. end;
  417.  
  418. procedure TToolbarButton97ActionLink.SetImageIndex (Value: Integer);
  419. begin
  420.   if IsImageIndexLinked then FClient.ImageIndex := Value;
  421. end;
  422. {$ENDIF}
  423.  
  424.  
  425. { TToolbarButton97 - internal }
  426.  
  427. type
  428.   TGlyphList = class(TImageList)
  429.   private
  430.     Used: TBits;
  431.     FCount: Integer;
  432.     function AllocateIndex: Integer;
  433.   public
  434.     constructor CreateSize (AWidth, AHeight: Integer);
  435.     destructor Destroy; override;
  436.     function Add (Image, Mask: TBitmap): Integer;
  437.     function AddMasked (Image: TBitmap; MaskColor: TColor): Integer;
  438.     procedure Delete (Index: Integer);
  439.     property Count: Integer read FCount;
  440.   end;
  441.  
  442.   TGlyphCache = class
  443.   private
  444.     GlyphLists: TList;
  445.   public
  446.     constructor Create;
  447.     destructor Destroy; override;
  448.     function GetList(AWidth, AHeight: Integer): TGlyphList;
  449.     procedure ReturnList(List: TGlyphList);
  450.     function Empty: Boolean;
  451.   end;
  452.  
  453.   TBoolInt = record
  454.     B: Boolean;
  455.     I: Integer;
  456.   end;
  457.  
  458.   TCustomImageListAccess = class(TCustomImageList);
  459.  
  460.   TButtonGlyph = class
  461.   private
  462.     FOriginal, FOriginalMask: TBitmap;
  463.     FCallDormant: Boolean;
  464.     FGlyphList: array[Boolean] of TGlyphList;
  465.     FImageIndex: Integer;
  466.     FImageList: TCustomImageList;
  467.     FImageChangeLink: TChangeLink;
  468.     FIndexs: array[Boolean, TButtonState97] of Integer;
  469.     FTransparentColor: TColor;
  470.     FNumGlyphs: TNumGlyphs97;
  471.     FOnChange: TNotifyEvent;
  472.     FOldDisabledStyle: Boolean;
  473.     procedure GlyphChanged (Sender: TObject);
  474.     procedure SetGlyph (Value: TBitmap);
  475.     procedure SetGlyphMask (Value: TBitmap);
  476.     procedure SetNumGlyphs (Value: TNumGlyphs97);
  477.     procedure UpdateNumGlyphs;
  478.     procedure Invalidate;
  479.     function CreateButtonGlyph (State: TButtonState97): TBoolInt;
  480.     procedure DrawButtonGlyph (Canvas: TCanvas; const GlyphPos: TPoint;
  481.       State: TButtonState97);
  482.     procedure DrawButtonText (Canvas: TCanvas;
  483.       const Caption: string; TextBounds: TRect;
  484.       WordWrap: Boolean; Alignment: TAlignment; State: TButtonState97);
  485.     procedure DrawButtonDropArrow (Canvas: TCanvas; const X, Y, AWidth: Integer;
  486.       State: TButtonState97);
  487.     procedure CalcButtonLayout (Canvas: TCanvas; const Client: TRect;
  488.       const Offset: TPoint; DrawGlyph, DrawCaption: Boolean;
  489.       const Caption: string; WordWrap: Boolean;
  490.       Layout: TButtonLayout; Margin, Spacing: Integer; DropArrow: Boolean;
  491.       DropArrowWidth: Integer; var GlyphPos, ArrowPos: TPoint;
  492.       var TextBounds: TRect);
  493.   public
  494.     constructor Create;
  495.     destructor Destroy; override;
  496.     { returns the text rectangle }
  497.     function Draw (Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
  498.       DrawGlyph, DrawCaption: Boolean; const Caption: string; WordWrap: Boolean;
  499.       Alignment: TAlignment; Layout: TButtonLayout; Margin, Spacing: Integer;
  500.       DropArrow: Boolean; DropArrowWidth: Integer; State: TButtonState97): TRect;
  501.     property Glyph: TBitmap read FOriginal write SetGlyph;
  502.     property GlyphMask: TBitmap read FOriginalMask write SetGlyphMask;
  503.     property NumGlyphs: TNumGlyphs97 read FNumGlyphs write SetNumGlyphs;
  504.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  505.   end;
  506.  
  507.  
  508. { TGlyphList }
  509.  
  510. constructor TGlyphList.CreateSize(AWidth, AHeight: Integer);
  511. begin
  512.   inherited CreateSize (AWidth, AHeight);
  513.   Used := TBits.Create;
  514. end;
  515.  
  516. destructor TGlyphList.Destroy;
  517. begin
  518.   Used.Free;
  519.   inherited;
  520. end;
  521.  
  522. function TGlyphList.AllocateIndex: Integer;
  523. begin
  524.   Result := Used.OpenBit;
  525.   if Result >= Used.Size then
  526.   begin
  527.     Result := inherited Add(nil, nil);
  528.     Used.Size := Result + 1;
  529.   end;
  530.   Used[Result] := True;
  531. end;
  532.  
  533. function TGlyphList.Add (Image, Mask: TBitmap): Integer;
  534. begin
  535.   Result := AllocateIndex;
  536.   Replace (Result, Image, Mask);
  537.   Inc (FCount);
  538. end;
  539.  
  540. function TGlyphList.AddMasked (Image: TBitmap; MaskColor: TColor): Integer;
  541.   procedure BugfreeReplaceMasked (Index: Integer; NewImage: TBitmap; MaskColor: TColor);
  542.     procedure CheckImage (Image: TGraphic);
  543.     begin
  544.       if Image = nil then Exit;
  545.       if (Image.Height < Height) or (Image.Width < Width) then
  546.         raise EInvalidOperation.Create({$IFNDEF TB97D3}LoadStr{$ENDIF}(SInvalidImageSize));
  547.     end;
  548.   var
  549.     TempIndex: Integer;
  550.     Image, Mask: TBitmap;
  551.   begin
  552.     if HandleAllocated then begin
  553.       CheckImage(NewImage);
  554.       TempIndex := inherited AddMasked(NewImage, MaskColor);
  555.       if TempIndex <> -1 then
  556.         try
  557.           Image := nil;
  558.           Mask := nil;
  559.           try
  560.             Image := TBitmap.Create;
  561.             Image.Height := Height;
  562.             Image.Width := Width;
  563.             Mask := TBitmap.Create;
  564.             Mask.Monochrome := True;
  565.             { ^ Prevents the "invisible glyph" problem when used with certain
  566.                 color schemes. (Fixed in Delphi 3.01) }
  567.             Mask.Height := Height;
  568.             Mask.Width := Width;
  569.             ImageList_Draw (Handle, TempIndex, Image.Canvas.Handle, 0, 0, ILD_NORMAL);
  570.             ImageList_Draw (Handle, TempIndex, Mask.Canvas.Handle, 0, 0, ILD_MASK);
  571.             if not ImageList_Replace(Handle, Index, Image.Handle, Mask.Handle) then
  572.               raise EInvalidOperation.Create({$IFNDEF TB97D3}LoadStr{$ENDIF}(SReplaceImage));
  573.           finally
  574.             Image.Free;
  575.             Mask.Free;
  576.           end;
  577.         finally
  578.           inherited Delete(TempIndex);
  579.         end
  580.       else
  581.         raise EInvalidOperation.Create({$IFNDEF TB97D3}LoadStr{$ENDIF}(SReplaceImage));
  582.     end;
  583.     Change;
  584.   end;
  585. begin
  586.   Result := AllocateIndex;
  587.   { This works two very serious bugs in the Delphi 2/BCB and Delphi 3
  588.     implementations of the ReplaceMasked method. In the Delphi 2 and BCB
  589.     versions of the ReplaceMasked method, it incorrectly uses ILD_NORMAL as
  590.     the last parameter for the second ImageList_Draw call, in effect causing
  591.     all white colors to be considered transparent also. And in the Delphi 2/3
  592.     and BCB versions it doesn't set Monochrome to True on the Mask bitmap,
  593.     causing the bitmaps to be invisible on certain color schemes. }
  594.   BugfreeReplaceMasked (Result, Image, MaskColor);
  595.   Inc (FCount);
  596. end;
  597.  
  598. procedure TGlyphList.Delete (Index: Integer);
  599. begin
  600.   if Used[Index] then begin
  601.     Dec(FCount);
  602.     Used[Index] := False;
  603.   end;
  604. end;
  605.  
  606. { TGlyphCache }
  607.  
  608. constructor TGlyphCache.Create;
  609. begin
  610.   inherited;
  611.   GlyphLists := TList.Create;
  612. end;
  613.  
  614. destructor TGlyphCache.Destroy;
  615. begin
  616.   GlyphLists.Free;
  617.   inherited;
  618. end;
  619.  
  620. function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
  621. var
  622.   I: Integer;
  623. begin
  624.   for I := GlyphLists.Count - 1 downto 0 do begin
  625.     Result := GlyphLists[I];
  626.     with Result do
  627.       if (AWidth = Width) and (AHeight = Height) then Exit;
  628.   end;
  629.   Result := TGlyphList.CreateSize(AWidth, AHeight);
  630.   GlyphLists.Add(Result);
  631. end;
  632.  
  633. procedure TGlyphCache.ReturnList(List: TGlyphList);
  634. begin
  635.   if List = nil then Exit;
  636.   if List.Count = 0 then begin
  637.     GlyphLists.Remove(List);
  638.     List.Free;
  639.   end;
  640. end;
  641.  
  642. function TGlyphCache.Empty: Boolean;
  643. begin
  644.   Result := GlyphLists.Count = 0;
  645. end;
  646.  
  647. var
  648.   GlyphCache: TGlyphCache = nil;
  649.   Pattern: TBitmap = nil;
  650.   PatternBtnFace, PatternBtnHighlight: TColor;
  651.   ButtonCount: Integer = 0;
  652.  
  653. procedure CreateBrushPattern;
  654. var
  655.   X, Y: Integer;
  656. begin
  657.   PatternBtnFace := GetSysColor(COLOR_BTNFACE);
  658.   PatternBtnHighlight := GetSysColor(COLOR_BTNHIGHLIGHT);
  659.   Pattern := TBitmap.Create;
  660.   with Pattern do begin
  661.     Width := 8;
  662.     Height := 8;
  663.     with Canvas do begin
  664.       Brush.Style := bsSolid;
  665.       Brush.Color := clBtnFace;
  666.       FillRect (Rect(0, 0, Width, Height));
  667.       for Y := 0 to 7 do
  668.         for X := 0 to 7 do
  669.           if Odd(Y) = Odd(X) then  { toggles between even/odd pixels }
  670.             Pixels[X, Y] := clBtnHighlight;     { on even/odd rows }
  671.     end;
  672.   end;
  673. end;
  674.  
  675.  
  676. { TButtonGlyph }
  677.  
  678. constructor TButtonGlyph.Create;
  679. var
  680.   B: Boolean;
  681.   I: TButtonState97;
  682. begin
  683.   inherited;
  684.   FCallDormant := True;
  685.   FImageIndex := -1;
  686.   FOriginal := TBitmap.Create;
  687.   FOriginal.OnChange := GlyphChanged;
  688.   FOriginalMask := TBitmap.Create;
  689.   FOriginalMask.OnChange := GlyphChanged;
  690.   FNumGlyphs := 1;
  691.   for B := False to True do
  692.     for I := Low(I) to High(I) do
  693.       FIndexs[B, I] := -1;
  694.   if GlyphCache = nil then
  695.     GlyphCache := TGlyphCache.Create;
  696. end;
  697.  
  698. destructor TButtonGlyph.Destroy;
  699. begin
  700.   FOriginalMask.Free;
  701.   FOriginal.Free;
  702.   FImageChangeLink.Free;
  703.   Invalidate;
  704.   if Assigned(GlyphCache) and GlyphCache.Empty then begin
  705.     GlyphCache.Free;
  706.     GlyphCache := nil;
  707.   end;
  708.   inherited;
  709. end;
  710.  
  711. procedure TButtonGlyph.Invalidate;
  712. var
  713.   B: Boolean;
  714.   I: TButtonState97;
  715. begin
  716.   for B := False to True do begin
  717.     for I := Low(I) to High(I) do 
  718.       if FIndexs[B, I] <> -1 then begin
  719.         FGlyphList[B].Delete (FIndexs[B, I]);
  720.         FIndexs[B, I] := -1;
  721.       end;
  722.     GlyphCache.ReturnList (FGlyphList[B]);
  723.     FGlyphList[B] := nil;
  724.   end;
  725. end;
  726.  
  727. procedure TButtonGlyph.GlyphChanged (Sender: TObject);
  728. begin
  729.   if (Sender = FOriginal) and (FOriginal.Width <> 0) and (FOriginal.Height <> 0) then
  730.     FTransparentColor := FOriginal.Canvas.Pixels[0, FOriginal.Height-1] or $02000000;
  731.   Invalidate;
  732.   if Assigned(FOnChange) then FOnChange (Self);
  733. end;
  734.  
  735. procedure TButtonGlyph.UpdateNumGlyphs;
  736. var
  737.   Glyphs: Integer;
  738. begin
  739.   if (FOriginal.Width <> 0) and (FOriginal.Height <> 0) and
  740.      (FOriginal.Width mod FOriginal.Height = 0) then begin
  741.     Glyphs := FOriginal.Width div FOriginal.Height;
  742.     if Glyphs > High(TNumGlyphs97) then Glyphs := 1;
  743.   end
  744.   else
  745.     Glyphs := 1;
  746.   SetNumGlyphs (Glyphs);
  747. end;
  748.  
  749. procedure TButtonGlyph.SetGlyph (Value: TBitmap);
  750. begin
  751.   Invalidate;
  752.   FOriginal.Assign (Value);
  753.   UpdateNumGlyphs;
  754. end;
  755.  
  756. procedure TButtonGlyph.SetGlyphMask (Value: TBitmap);
  757. begin
  758.   Invalidate;
  759.   FOriginalMask.Assign (Value);
  760. end;
  761.  
  762. procedure TButtonGlyph.SetNumGlyphs (Value: TNumGlyphs97);
  763. begin
  764.   Invalidate;
  765.   if (FImageList <> nil) or (Value < Low(TNumGlyphs97)) or
  766.      (Value > High(TNumGlyphs97)) then
  767.     FNumGlyphs := 1
  768.   else
  769.     FNumGlyphs := Value;
  770.   GlyphChanged (nil);
  771. end;
  772.  
  773. function TButtonGlyph.CreateButtonGlyph (State: TButtonState97): TBoolInt;
  774. const
  775.   ROP_DSPDxax = $00E20746;
  776.   ROP_PSDPxax = $00B8074A;
  777.   ROP_DSna = $00220326;  { D & ~S }
  778.  
  779.   procedure GenerateMaskBitmapFromDIB (const MaskBitmap, SourceBitmap: TBitmap;
  780.     const SourceOffset, SourceSize: TPoint; TransColors: array of TColor);
  781.   { This a special procedure meant for generating monochrome masks from
  782.     >4 bpp color DIB sections. Because each video driver seems to sport its own
  783.     interpretation of how to handle DIB sections, a workaround procedure like
  784.     this was necessary. }
  785.   type
  786.     TColorArray = array[0..536870910] of TColorRef;
  787.   var
  788.     Info: packed record
  789.       Header: TBitmapInfoHeader;
  790.       Colors: array[0..1] of TColorRef;
  791.     end;
  792.     W, H: Integer;
  793.     I, Y, X: Integer;
  794.     Pixels: ^TColorArray;
  795.     Pixel: ^TColorRef;
  796.     MonoPixels: Pointer;
  797.     MonoPixel, StartMonoPixel: ^Byte;
  798.     MonoScanLineSize, CurBit: Integer;
  799.     DC: HDC;
  800.     MaskBmp: HBITMAP;
  801.   begin
  802.     W := SourceBitmap.Width;
  803.     H := SourceBitmap.Height;
  804.     MonoScanLineSize := SourceSize.X div 8;
  805.     if SourceSize.X mod 8 <> 0 then
  806.       Inc (MonoScanLineSize);
  807.     if MonoScanLineSize mod 4 <> 0 then  { Compensate for scan line boundary }
  808.       MonoScanLineSize := (MonoScanLineSize and not 3) + 4;
  809.     MonoPixels := AllocMem(MonoScanLineSize * SourceSize.Y);  { AllocMem is used because it initializes to zero }
  810.     try
  811.       GetMem (Pixels, W * H * 4);
  812.       try
  813.         FillChar (Info, SizeOf(Info), 0);
  814.         with Info do begin
  815.           with Header do begin
  816.             biSize := SizeOf(TBitmapInfoHeader);
  817.             biWidth := W;
  818.             biHeight := -H;  { negative number makes it a top-down DIB }
  819.             biPlanes := 1;
  820.             biBitCount := 32;
  821.             {biCompression := BI_RGB;}  { implied due to the FillChar zeroing }
  822.           end;
  823.           {Colors[0] := clBlack;}  { implied due to the FillChar zeroing }
  824.           Colors[1] := clWhite;
  825.         end;
  826.         DC := CreateCompatibleDC(0);
  827.         GetDIBits (DC, SourceBitmap.Handle, 0, H, Pixels, PBitmapInfo(@Info)^,
  828.           DIB_RGB_COLORS);
  829.         DeleteDC (DC);
  830.  
  831.         for I := 0 to High(TransColors) do
  832.           if TransColors[I] = -1 then
  833.             TransColors[I] := Pixels[W * (H-1)] and $FFFFFF;
  834.               { ^ 'and' operation is necessary because the high byte is undefined }
  835.  
  836.         MonoPixel := MonoPixels;
  837.         for Y := SourceOffset.Y to SourceOffset.Y+SourceSize.Y-1 do begin
  838.           StartMonoPixel := MonoPixel;
  839.           CurBit := 7;
  840.           Pixel := @Pixels[(Y * W) + SourceOffset.X];
  841.           for X := 0 to SourceSize.X-1 do begin
  842.             for I := 0 to High(TransColors) do
  843.               if Pixel^ and $FFFFFF = Cardinal(TransColors[I]) then begin
  844.                 { ^ 'and' operation is necessary because the high byte is undefined }
  845.                 MonoPixel^ := MonoPixel^ or (1 shl CurBit);
  846.                 Break;
  847.               end;
  848.             Dec (CurBit);
  849.             if CurBit < 0 then begin
  850.               Inc (Integer(MonoPixel));
  851.               CurBit := 7;
  852.             end;
  853.             Inc (Integer(Pixel), SizeOf(Longint));  { proceed to the next pixel }
  854.           end;
  855.           Integer(MonoPixel) := Integer(StartMonoPixel) + MonoScanLineSize;
  856.         end;
  857.       finally
  858.         FreeMem (Pixels);
  859.       end;
  860.  
  861.       { Write new bits into a new HBITMAP, and assign this handle to MaskBitmap }
  862.       MaskBmp := CreateBitmap(SourceSize.X, SourceSize.Y, 1, 1, nil);
  863.       with Info.Header do begin
  864.         biWidth := SourceSize.X;
  865.         biHeight := -SourceSize.Y;  { negative number makes it a top-down DIB }
  866.         biPlanes := 1;
  867.         biBitCount := 1;
  868.       end;
  869.       DC := CreateCompatibleDC(0);
  870.       SetDIBits (DC, MaskBmp, 0, SourceSize.Y, MonoPixels, PBitmapInfo(@Info)^,
  871.         DIB_RGB_COLORS);
  872.       DeleteDC (DC);
  873.     finally
  874.       FreeMem (MonoPixels);
  875.     end;
  876.  
  877.     MaskBitmap.Handle := MaskBmp;
  878.   end;
  879.   procedure GenerateMaskBitmap (const MaskBitmap, SourceBitmap: TBitmap;
  880.     const SourceOffset, SourceSize: TPoint; const TransColors: array of TColor);
  881.   { Returns handle of a monochrome bitmap, with pixels in SourceBitmap of color
  882.     TransColor set to white in the resulting bitmap. All other colors of
  883.     SourceBitmap are set to black in the resulting bitmap. This uses the
  884.     regular ROP_DSPDxax BitBlt method. }
  885.   var
  886.     CanvasHandle: HDC;
  887.     SaveBkColor: TColorRef;
  888.     DC: HDC;
  889.     MaskBmp, SaveBmp: HBITMAP;
  890.     I: Integer;
  891.   const
  892.     ROP: array[Boolean] of DWORD = (SRCPAINT, SRCCOPY);
  893.   begin
  894.     CanvasHandle := SourceBitmap.Canvas.Handle;
  895.  
  896.     MaskBmp := CreateBitmap(SourceSize.X, SourceSize.Y, 1, 1, nil);
  897.     DC := CreateCompatibleDC(0);
  898.     SaveBmp := SelectObject(DC, MaskBmp);
  899.     SaveBkColor := GetBkColor(CanvasHandle);
  900.     for I := 0 to High(TransColors) do begin
  901.       SetBkColor (CanvasHandle, ColorToRGB(TransColors[I]));
  902.       BitBlt (DC, 0, 0, SourceSize.X, SourceSize.Y, CanvasHandle,
  903.         SourceOffset.X, SourceOffset.Y, ROP[I = 0]);
  904.     end;
  905.     SetBkColor (CanvasHandle, SaveBkColor);
  906.     SelectObject (DC, SaveBmp);
  907.     DeleteDC (DC);
  908.  
  909.     MaskBitmap.Handle := MaskBmp;
  910.   end;
  911.   procedure ReplaceBitmapColorsFromMask (const MaskBitmap, DestBitmap: TBitmap;
  912.     const DestOffset, DestSize: TPoint; const ReplaceColor: TColor);
  913.   var
  914.     DestDC: HDC;
  915.     SaveBrush: HBRUSH;
  916.     SaveTextColor, SaveBkColor: TColorRef;
  917.   begin
  918.     DestDC := DestBitmap.Canvas.Handle;
  919.  
  920.     SaveBrush := SelectObject(DestDC, CreateSolidBrush(ColorToRGB(ReplaceColor)));
  921.     SaveTextColor := SetTextColor(DestDC, clBlack);
  922.     SaveBkColor := SetBkColor(DestDC, clWhite);
  923.     BitBlt (DestDC, DestOffset.X, DestOffset.Y, DestSize.X, DestSize.Y,
  924.       MaskBitmap.Canvas.Handle, 0, 0, ROP_DSPDxax);
  925.     SetBkColor (DestDC, SaveBkColor);
  926.     SetTextColor (DestDC, SaveTextColor);
  927.     DeleteObject (SelectObject(DestDC, SaveBrush));
  928.   end;
  929.   function CopyBitmapToDDB (const SourceBitmap: TBitmap): TBitmap;
  930.   { Makes a device-dependent duplicate of SourceBitmap. The color palette,
  931.     if any, is preserved. }
  932.   var
  933.     SB: HBITMAP;
  934.     SavePalette: HPALETTE;
  935.     DC: HDC;
  936.     BitmapInfo: packed record
  937.       Header: TBitmapInfoHeader;
  938.       Colors: array[0..255] of TColorRef;
  939.     end;
  940.     Bits: Pointer;
  941.   begin
  942.     Result := TBitmap.Create;
  943.     try
  944.       Result.Palette := CopyPalette(SourceBitmap.Palette);
  945.       Result.Width := SourceBitmap.Width;
  946.       Result.Height := SourceBitmap.Height;
  947.       SB := SourceBitmap.Handle;
  948.       if SB = 0 then Exit;  { it would have a null handle if its width or height was zero }
  949.       SavePalette := 0;
  950.       DC := CreateCompatibleDC(0);
  951.       try
  952.         if Result.Palette <> 0 then begin
  953.           SavePalette := SelectPalette(DC, Result.Palette, False);
  954.           RealizePalette (DC);
  955.         end;
  956.         BitmapInfo.Header.biSize := SizeOf(TBitmapInfoHeader);
  957.         BitmapInfo.Header.biBitCount := 0;  { instructs GetDIBits not to fill in the color table }
  958.         { First retrieve the BitmapInfo header only }
  959.         if GetDIBits(DC, SB, 0, 0, nil, PBitmapInfo(@BitmapInfo)^, DIB_RGB_COLORS) <> 0 then begin
  960.           GetMem (Bits, BitmapInfo.Header.biSizeImage);
  961.           try
  962.             { Then read the actual bits }
  963.             if GetDIBits(DC, SB, 0, SourceBitmap.Height, Bits, PBitmapInfo(@BitmapInfo)^, DIB_RGB_COLORS) <> 0 then
  964.               { And copy them to the resulting bitmap }
  965.               SetDIBits (DC, Result.Handle, 0, SourceBitmap.Height, Bits, PBitmapInfo(@BitmapInfo)^, DIB_RGB_COLORS);
  966.           finally
  967.             FreeMem (Bits);
  968.           end;
  969.         end;
  970.       finally
  971.         if SavePalette <> 0 then SelectPalette (DC, SavePalette, False);
  972.         DeleteDC (DC);
  973.       end;
  974.     except
  975.       Result.Free;
  976.       raise;
  977.     end;
  978.   end;
  979. const
  980.   ROPs: array[Boolean] of DWORD = (ROP_PSDPxax, ROP_DSPDxax);
  981. var
  982.   OriginalBmp, OriginalMaskBmp, TmpImage, DDB, MonoBmp, MaskBmp, UseMaskBmp: TBitmap;
  983.   I: TButtonState97;
  984.   B: Boolean;
  985.   AddPixels, IWidth, IHeight, IWidthA, IHeightA: Integer;
  986.   IRect, IRectA, SourceRect, R: TRect;
  987.   DC: HDC;
  988.   UsesMask: Boolean;
  989. {$IFDEF TB97D3}
  990.   IsHighColorDIB: Boolean;
  991. {$ELSE}
  992. const
  993.   IsHighColorDIB = False;
  994. {$ENDIF}
  995. begin
  996.   if (State <> bsDisabled) and (Ord(State) >= NumGlyphs) then
  997.     State := bsUp;
  998.   Result.B := True;
  999.   Result.I := FIndexs[True, State];
  1000.   if Result.I = -1 then begin
  1001.     Result.B := False;
  1002.     Result.I := FIndexs[False, State];
  1003.   end;
  1004.   if Result.I <> -1 then Exit;
  1005.   if FImageList = nil then begin
  1006.     if (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit;
  1007.     UsesMask := (FOriginalMask.Width <> 0) and (FOriginalMask.Height <> 0);
  1008.   end
  1009.   else begin
  1010.     if (FImageIndex < 0) or (FImageIndex >= FImageList.Count) then Exit;
  1011.     UsesMask := False;
  1012.   end;
  1013.   B := State <> bsDisabled;
  1014.   { + AddPixels is to make sure the highlight color on generated disabled glyphs
  1015.     doesn't get cut off }
  1016.   if FImageList = nil then begin
  1017.     IWidthA := FOriginal.Width div FNumGlyphs;
  1018.     IHeightA := FOriginal.Height;
  1019.   end
  1020.   else begin
  1021.     IWidthA := TCustomImageListAccess(FImageList).Width;
  1022.     IHeightA := TCustomImageListAccess(FImageList).Height;
  1023.   end;
  1024.   IRectA := Rect(0, 0, IWidthA, IHeightA);
  1025.   AddPixels := Ord(State = bsDisabled);
  1026.   IWidth := IWidthA + AddPixels;
  1027.   IHeight := IHeightA + AddPixels;
  1028.   IRect := Rect(0, 0, IWidth, IHeight);
  1029.   if FGlyphList[B] = nil then begin
  1030.     if GlyphCache = nil then
  1031.       GlyphCache := TGlyphCache.Create;
  1032.     FGlyphList[B] := GlyphCache.GetList(IWidth, IHeight);
  1033.   end;
  1034.   {$IFDEF TB97D3}
  1035.   IsHighColorDIB := (FImageList = nil) and (FOriginal.PixelFormat > pf4bit);
  1036.   {$ENDIF}
  1037.   OriginalBmp := nil;
  1038.   OriginalMaskBmp := nil;
  1039.   TmpImage := nil;
  1040.   MaskBmp := nil;
  1041.   try
  1042.     OriginalBmp := TBitmap.Create;
  1043.     OriginalBmp.Assign (FOriginal);
  1044.     OriginalMaskBmp := TBitmap.Create;
  1045.     OriginalMaskBmp.Assign (FOriginalMask);
  1046.     TmpImage := TBitmap.Create;
  1047.     TmpImage.Width := IWidth;
  1048.     TmpImage.Height := IHeight;
  1049.     TmpImage.Canvas.Brush.Color := clBtnFace;
  1050.     if FImageList = nil then
  1051.       TmpImage.Palette := CopyPalette(OriginalBmp.Palette);
  1052.     I := State;
  1053.     if Ord(I) >= NumGlyphs then I := bsUp;
  1054.     SourceRect := Bounds(Ord(I) * IWidthA, 0, IWidthA, IHeightA);
  1055.     if FImageList <> nil then begin
  1056.       MaskBmp := TBitmap.Create;
  1057.       MaskBmp.Monochrome := True;
  1058.       MaskBmp.Width := IWidthA;
  1059.       MaskBmp.Height := IHeightA;
  1060.       ImageList_Draw (FImageList.Handle, FImageIndex, MaskBmp.Canvas.Handle,
  1061.         0, 0, ILD_MASK);
  1062.     end;
  1063.  
  1064.     if State <> bsDisabled then begin
  1065.       if FImageList = nil then begin
  1066.         TmpImage.Canvas.CopyRect (IRectA, OriginalBmp.Canvas, SourceRect);
  1067.         if not UsesMask then begin
  1068.           {$IFDEF TB97D3}
  1069.           { Use clDefault instead of FTransparentColor whereever possible to
  1070.             ensure compatibility with all video drivers when using high-color
  1071.             (> 4 bpp) DIB glyphs }
  1072.           FIndexs[B, State] := FGlyphList[B].AddMasked(TmpImage, clDefault);
  1073.           {$ELSE}
  1074.           FIndexs[B, State] := FGlyphList[B].AddMasked(TmpImage, FTransparentColor);
  1075.           {$ENDIF}
  1076.         end
  1077.         else begin
  1078.           MonoBmp := TBitmap.Create;
  1079.           try
  1080.             MonoBmp.Monochrome := True;
  1081.             MonoBmp.Width := IWidth;
  1082.             MonoBmp.Height := IHeight;
  1083.             MonoBmp.Canvas.CopyRect (IRectA, OriginalMaskBmp.Canvas, SourceRect);
  1084.             FIndexs[B, State] := FGlyphList[B].Add(TmpImage, MonoBmp);
  1085.           finally
  1086.             MonoBmp.Free;
  1087.           end;
  1088.         end;
  1089.       end
  1090.       else begin
  1091.         ImageList_Draw (FImageList.Handle, FImageIndex, TmpImage.Canvas.Handle,
  1092.           0, 0, ILD_NORMAL);
  1093.         FIndexs[B, State] := FGlyphList[B].Add(TmpImage, MaskBmp);
  1094.       end;
  1095.     end
  1096.     else begin
  1097.       MonoBmp := nil;
  1098.       DDB := nil;
  1099.       try
  1100.         MonoBmp := TBitmap.Create;
  1101.         { Uses the CopyBitmapToDDB to work around a Delphi 3 flaw. If you copy
  1102.           a DIB to a second bitmap via Assign, change the HandleType of the
  1103.           second bitmap to bmDDB, then try to read the Handle property, Delphi
  1104.           converts it back to a DIB. }
  1105.         if FImageList = nil then
  1106.           DDB := CopyBitmapToDDB(OriginalBmp)
  1107.         else begin
  1108.           DDB := TBitmap.Create;
  1109.           DDB.Width := IWidthA;
  1110.           DDB.Height := IHeightA;
  1111.           ImageList_Draw (FImageList.Handle, FImageIndex, DDB.Canvas.Handle,
  1112.             0, 0, ILD_NORMAL);
  1113.         end;
  1114.         if NumGlyphs > 1 then
  1115.           with TmpImage.Canvas do begin
  1116.             CopyRect (IRectA, DDB.Canvas, SourceRect);
  1117.  
  1118.             { Convert white to clBtnHighlight }
  1119.             if not IsHighColorDIB then
  1120.               GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft,
  1121.                 IRectA.BottomRight, [GetNearestColor(OriginalBmp.Canvas.Handle, clWhite)])
  1122.             else
  1123.               GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp, SourceRect.TopLeft,
  1124.                 IRectA.BottomRight, [clWhite]);
  1125.             ReplaceBitmapColorsFromMask (MonoBmp, TmpImage, IRectA.TopLeft,
  1126.               IRectA.BottomRight, clBtnHighlight);
  1127.  
  1128.             { Convert gray to clBtnShadow }
  1129.             if not IsHighColorDIB then
  1130.               GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft,
  1131.                 IRectA.BottomRight, [GetNearestColor(OriginalBmp.Canvas.Handle, clGray)])
  1132.             else
  1133.               GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp, SourceRect.TopLeft,
  1134.                 IRectA.BottomRight, [clGray]);
  1135.             ReplaceBitmapColorsFromMask (MonoBmp, TmpImage, IRectA.TopLeft,
  1136.               IRectA.BottomRight, clBtnShadow);
  1137.  
  1138.             if not UsesMask then begin
  1139.               { Generate the transparent mask in MonoBmp. The reason why
  1140.                 it doesn't just use a mask color is because the mask needs
  1141.                 to be of the glyph -before- the clBtnHighlight/Shadow were
  1142.                 translated }
  1143.               if not IsHighColorDIB then
  1144.                 GenerateMaskBitmap (MonoBmp, DDB,
  1145.                   SourceRect.TopLeft, IRectA.BottomRight, FTransparentColor)
  1146.               else
  1147.                 GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp,
  1148.                   SourceRect.TopLeft, IRectA.BottomRight, [-1]);
  1149.             end
  1150.             else
  1151.               MonoBmp.Canvas.CopyRect (IRectA, OriginalMaskBmp.Canvas, SourceRect);
  1152.             with MonoBmp do begin
  1153.               Width := Width + AddPixels;
  1154.               Height := Height + AddPixels;
  1155.               { Set the additional bottom and right row on disabled glyph
  1156.                 masks to white so that it always shines through, since the
  1157.                 bottom and right row on TmpImage was left uninitialized }
  1158.               Canvas.Pen.Color := clWhite;
  1159.               Canvas.PolyLine ([Point(0, Height-1), Point(Width-1, Height-1),
  1160.                 Point(Width-1, -1)]);
  1161.             end;
  1162.  
  1163.             FIndexs[B, State] := FGlyphList[B].Add(TmpImage, MonoBmp);
  1164.           end
  1165.         else begin
  1166.           { Create a disabled version }
  1167.           if FOldDisabledStyle then begin
  1168.             { "Old" TSpeedButton style }
  1169.             if FImageList = nil then begin
  1170.               if not UsesMask then begin
  1171.                 if IsHighColorDIB then
  1172.                   GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp,
  1173.                     SourceRect.TopLeft, IRectA.BottomRight, [clBlack])
  1174.                 else begin
  1175.                   with MonoBmp do begin
  1176.                     Assign (DDB);  { must be a DDB for this to work right }
  1177.                     Canvas.Brush.Color := clBlack;
  1178.                     Monochrome := True;
  1179.                   end;
  1180.                 end;
  1181.               end
  1182.               else begin
  1183.                 MonoBmp.Assign (DDB);  { must be a DDB for this to work right }
  1184.                 with TBitmap.Create do
  1185.                   try
  1186.                     Monochrome := True;
  1187.                     Width := OriginalMaskBmp.Width;
  1188.                     Height := OriginalMaskBmp.Height;
  1189.                     R := Rect(0, 0, Width, Height);
  1190.                     Canvas.CopyRect (R, OriginalMaskBmp.Canvas, R);
  1191.                     DC := Canvas.Handle;
  1192.                     with MonoBmp.Canvas do begin
  1193.                       BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
  1194.                         SourceRect.Left, SourceRect.Top, ROP_DSna);
  1195.                       BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
  1196.                         SourceRect.Left, SourceRect.Top, SRCPAINT);
  1197.                     end;
  1198.                   finally
  1199.                     Free;
  1200.                   end;
  1201.                 MonoBmp.Canvas.Brush.Color := clBlack;
  1202.                 MonoBmp.Monochrome := True;
  1203.               end
  1204.             end
  1205.             else begin
  1206.               with MonoBmp do begin
  1207.                 Width := IWidthA;
  1208.                 Height := IHeightA;
  1209.                 Canvas.Brush.Color := clWhite;
  1210.                 Canvas.FillRect (IRectA);
  1211.                 ImageList_Draw (FImageList.Handle, FImageIndex, Canvas.Handle,
  1212.                   0, 0, ILD_TRANSPARENT);
  1213.                 Canvas.Brush.Color := clBlack;
  1214.                 Monochrome := True;
  1215.               end;
  1216.             end;
  1217.           end
  1218.           else begin
  1219.             { The new Office 97 / MFC look }
  1220.             if not UsesMask and (FImageList = nil) then begin
  1221.               with TmpImage.Canvas do begin
  1222.                 if not IsHighColorDIB then
  1223.                   GenerateMaskBitmap (MonoBmp, DDB, IRectA.TopLeft,
  1224.                     IRectA.BottomRight, [FTransparentColor, clWhite, clSilver])
  1225.                 else
  1226.                   GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp,
  1227.                     SourceRect.TopLeft, IRectA.BottomRight, [-1, clWhite, clSilver]);
  1228.               end;
  1229.             end
  1230.             else begin
  1231.               { Generate the mask in MonoBmp. Make clWhite and clSilver transparent. }
  1232.               if not IsHighColorDIB then
  1233.                 GenerateMaskBitmap (MonoBmp, DDB, SourceRect.TopLeft,
  1234.                   IRectA.BottomRight, [clWhite, clSilver])
  1235.               else
  1236.                 GenerateMaskBitmapFromDIB (MonoBmp, OriginalBmp, SourceRect.TopLeft,
  1237.                   IRectA.BottomRight, [clWhite, clSilver]);
  1238.               if FImageList = nil then
  1239.                 UseMaskBmp := OriginalMaskBmp
  1240.               else
  1241.                 UseMaskBmp := MaskBmp;
  1242.               { and all the white colors in UseMaskBmp }
  1243.               with TBitmap.Create do
  1244.                 try
  1245.                   Monochrome := True;
  1246.                   Width := UseMaskBmp.Width;
  1247.                   Height := UseMaskBmp.Height;
  1248.                   R := Rect(0, 0, Width, Height);
  1249.                   Canvas.CopyRect (R, UseMaskBmp.Canvas, R);
  1250.                   DC := Canvas.Handle;
  1251.                   with MonoBmp.Canvas do begin
  1252.                     BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
  1253.                       SourceRect.Left, SourceRect.Top, ROP_DSna);
  1254.                     BitBlt (Handle, 0, 0, IWidthA, IHeightA, DC,
  1255.                       SourceRect.Left, SourceRect.Top, SRCPAINT);
  1256.                   end;
  1257.                 finally
  1258.                   Free;
  1259.                 end;
  1260.             end;
  1261.           end;
  1262.  
  1263.           with TmpImage.Canvas do begin
  1264.             Brush.Color := clBtnFace;
  1265.             FillRect (IRect);
  1266.             Brush.Color := clBtnHighlight;
  1267.             DC := Handle;
  1268.             SetTextColor (DC, clBlack);
  1269.             SetBkColor (DC, clWhite);
  1270.             BitBlt (DC, 1, 1, IWidthA, IHeightA,
  1271.               MonoBmp.Canvas.Handle, 0, 0, ROPs[FOldDisabledStyle]);
  1272.             Brush.Color := clBtnShadow;
  1273.             DC := Handle;
  1274.             SetTextColor (DC, clBlack);
  1275.             SetBkColor (DC, clWhite);
  1276.             BitBlt (DC, 0, 0, IWidthA, IHeightA,
  1277.               MonoBmp.Canvas.Handle, 0, 0, ROPs[FOldDisabledStyle]);
  1278.           end;
  1279.  
  1280.           FIndexs[B, State] := FGlyphList[B].AddMasked(TmpImage, clBtnFace);
  1281.         end;
  1282.       finally
  1283.         DDB.Free;
  1284.         MonoBmp.Free;
  1285.       end;
  1286.     end;
  1287.   finally
  1288.     MaskBmp.Free;
  1289.     TmpImage.Free;
  1290.     OriginalMaskBmp.Free;
  1291.     OriginalBmp.Free;
  1292.   end;
  1293.   Result.B := B;
  1294.   Result.I := FIndexs[B, State];
  1295.   { Note: Due to a bug in graphics.pas, Delphi 2's VCL crashes if Dormant is
  1296.     called on an empty bitmap, so to prevent this it must check Width/Height
  1297.     first }
  1298.   if {$IFNDEF TB97D3} (FOriginal.Width <> 0) and (FOriginal.Height <> 0) and {$ENDIF}
  1299.      FCallDormant then
  1300.     FOriginal.Dormant;
  1301.   {$IFNDEF TB97D3} if (FOriginalMask.Width <> 0) and (FOriginalMask.Height <> 0) then {$ENDIF}
  1302.     FOriginalMask.Dormant;
  1303. end;
  1304.  
  1305. procedure TButtonGlyph.DrawButtonGlyph (Canvas: TCanvas; const GlyphPos: TPoint;
  1306.   State: TButtonState97);
  1307. var
  1308.   Index: TBoolInt;
  1309. begin
  1310.   Index := CreateButtonGlyph(State);
  1311.   if Index.I <> -1 then
  1312.     ImageList_DrawEx (FGlyphList[Index.B].Handle, Index.I, Canvas.Handle,
  1313.       GlyphPos.X, GlyphPos.Y, 0, 0, CLR_NONE, CLR_NONE, ILD_TRANSPARENT);
  1314. end;
  1315.  
  1316. procedure TButtonGlyph.DrawButtonText (Canvas: TCanvas; const Caption: string;
  1317.   TextBounds: TRect; WordWrap: Boolean; Alignment: TAlignment;
  1318.   State: TButtonState97);
  1319. const
  1320.   AlignmentFlags: array[TAlignment] of UINT = (DT_LEFT, DT_RIGHT, DT_CENTER);
  1321. var
  1322.   Format: UINT;
  1323. begin
  1324.   Format := DT_VCENTER or AlignmentFlags[Alignment];
  1325.   if not WordWrap then
  1326.     Format := Format or DT_SINGLELINE
  1327.   else
  1328.     Format := Format or DT_WORDBREAK;
  1329.   with Canvas do begin
  1330.     Brush.Style := bsClear;
  1331.     if State = bsDisabled then begin
  1332.       OffsetRect (TextBounds, 1, 1);
  1333.       Font.Color := clBtnHighlight;
  1334.       DrawText (Handle, PChar(Caption), Length(Caption), TextBounds, Format);
  1335.       OffsetRect (TextBounds, -1, -1);
  1336.       Font.Color := clBtnShadow;
  1337.       DrawText (Handle, PChar(Caption), Length(Caption), TextBounds, Format);
  1338.     end
  1339.     else
  1340.       DrawText (Handle, PChar(Caption), Length(Caption), TextBounds, Format);
  1341.   end;
  1342. end;
  1343.  
  1344. procedure TButtonGlyph.DrawButtonDropArrow (Canvas: TCanvas;
  1345.   const X, Y, AWidth: Integer; State: TButtonState97);
  1346. var
  1347.   X2: Integer;
  1348. begin
  1349.   with Canvas do begin
  1350.     X2 := X + AWidth div 2;
  1351.     if State = bsDisabled then begin
  1352.       Pen.Color := clBtnHighlight;
  1353.       Brush.Color := clBtnHighlight;
  1354.       Polygon ([Point(X2-1, Y+1), Point(X2+3, Y+1), Point(X2+1, Y+3)]);
  1355.       Pen.Color := clBtnShadow;
  1356.       Brush.Color := clBtnShadow;
  1357.       Polygon ([Point(X2-2, Y), Point(X2+2, Y), Point(X2, Y+2)]);
  1358.     end
  1359.     else begin
  1360.       Pen.Color := Font.Color;
  1361.       Brush.Color := Font.Color;
  1362.       Polygon ([Point(X2-2, Y), Point(X2+2, Y), Point(X2, Y+2)]);
  1363.     end;
  1364.   end;
  1365. end;
  1366.  
  1367. procedure TButtonGlyph.CalcButtonLayout (Canvas: TCanvas; const Client: TRect;
  1368.   const Offset: TPoint; DrawGlyph, DrawCaption: Boolean; const Caption: string;
  1369.   WordWrap: Boolean; Layout: TButtonLayout; Margin, Spacing: Integer;
  1370.   DropArrow: Boolean; DropArrowWidth: Integer; var GlyphPos, ArrowPos: TPoint;
  1371.   var TextBounds: TRect);
  1372. var
  1373.   TextPos: TPoint;
  1374.   ClientSize, GlyphSize, TextSize, ArrowSize: TPoint;
  1375.   HasGlyph: Boolean;
  1376.   TotalSize: TPoint;
  1377.   Format: UINT;
  1378.   Margin1, Spacing1: Integer;
  1379.   LayoutLeftOrRight: Boolean;
  1380. begin
  1381.   { calculate the item sizes }
  1382.   ClientSize := Point(Client.Right-Client.Left, Client.Bottom-Client.Top);
  1383.  
  1384.   GlyphSize.X := 0;
  1385.   GlyphSize.Y := 0;
  1386.   if DrawGlyph then begin
  1387.     if FImageList = nil then begin
  1388.       if FOriginal <> nil then begin
  1389.         GlyphSize.X := FOriginal.Width div FNumGlyphs;
  1390.         GlyphSize.Y := FOriginal.Height;
  1391.       end;
  1392.     end
  1393.     else begin
  1394.       GlyphSize.X := TCustomImageListAccess(FImageList).Width;
  1395.       GlyphSize.Y := TCustomImageListAccess(FImageList).Height;
  1396.     end;
  1397.   end;
  1398.   HasGlyph := (GlyphSize.X <> 0) and (GlyphSize.Y <> 0);
  1399.  
  1400.   if DropArrow then begin
  1401.     ArrowSize.X := DropArrowWidth;
  1402.     ArrowSize.Y := 3;
  1403.   end
  1404.   else begin
  1405.     ArrowSize.X := 0;
  1406.     ArrowSize.Y := 0;
  1407.   end;
  1408.  
  1409.   LayoutLeftOrRight := Layout in [blGlyphLeft, blGlyphRight];
  1410.   if not LayoutLeftOrRight and not HasGlyph then begin
  1411.     Layout := blGlyphLeft;
  1412.     LayoutLeftOrRight := True;
  1413.   end;
  1414.  
  1415.   if DrawCaption and (Caption <> '') then begin
  1416.     TextBounds := Rect(0, 0, Client.Right-Client.Left, 0);
  1417.     if LayoutLeftOrRight then
  1418.       Dec (TextBounds.Right, ArrowSize.X);
  1419.     Format := DT_CALCRECT;
  1420.     if WordWrap then begin
  1421.       Format := Format or DT_WORDBREAK;
  1422.       Margin1 := 4;
  1423.       if LayoutLeftOrRight and HasGlyph then begin
  1424.         if Spacing = -1 then
  1425.           Spacing1 := 4
  1426.         else
  1427.           Spacing1 := Spacing;
  1428.         Dec (TextBounds.Right, GlyphSize.X + Spacing1);
  1429.         if Margin <> -1 then
  1430.           Margin1 := Margin
  1431.         else
  1432.         if Spacing <> -1 then
  1433.           Margin1 := Spacing;
  1434.       end;
  1435.       Dec (TextBounds.Right, Margin1 * 2);
  1436.     end;
  1437.     DrawText (Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, Format);
  1438.     TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
  1439.       TextBounds.Top);
  1440.   end
  1441.   else begin
  1442.     TextBounds := Rect(0, 0, 0, 0);
  1443.     TextSize := Point(0,0);
  1444.   end;
  1445.  
  1446.   { If the layout has the glyph on the right or the left, then both the
  1447.     text and the glyph are centered vertically.  If the glyph is on the top
  1448.     or the bottom, then both the text and the glyph are centered horizontally.}
  1449.   if LayoutLeftOrRight then begin
  1450.     GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
  1451.     TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  1452.   end
  1453.   else begin
  1454.     GlyphPos.X := (ClientSize.X - GlyphSize.X - ArrowSize.X + 1) div 2;
  1455.     TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
  1456.     if not HasGlyph then
  1457.       ArrowPos.X := TextPos.X + TextSize.X
  1458.     else
  1459.       ArrowPos.X := GlyphPos.X + GlyphSize.X;
  1460.   end;
  1461.  
  1462.   { if there is no text or no bitmap, then Spacing is irrelevant }
  1463.   if (TextSize.X = 0) or (TextSize.Y = 0) or not HasGlyph then
  1464.     Spacing := 0;
  1465.  
  1466.   { adjust Margin and Spacing }
  1467.   if Margin = -1 then begin
  1468.     if Spacing = -1 then begin
  1469.       TotalSize := Point(GlyphSize.X + TextSize.X + ArrowSize.X,
  1470.         GlyphSize.Y + TextSize.Y);
  1471.       if LayoutLeftOrRight then
  1472.         Margin := (ClientSize.X - TotalSize.X) div 3
  1473.       else
  1474.         Margin := (ClientSize.Y - TotalSize.Y) div 3;
  1475.       Spacing := Margin;
  1476.     end
  1477.     else begin
  1478.       TotalSize := Point(GlyphSize.X + Spacing + TextSize.X + ArrowSize.X,
  1479.         GlyphSize.Y + Spacing + TextSize.Y);
  1480.       if LayoutLeftOrRight then
  1481.         Margin := (ClientSize.X - TotalSize.X + 1) div 2
  1482.       else
  1483.         Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
  1484.     end;
  1485.   end
  1486.   else begin
  1487.     if Spacing = -1 then begin
  1488.       TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X + ArrowSize.X),
  1489.         ClientSize.Y - (Margin + GlyphSize.Y));
  1490.       if LayoutLeftOrRight then
  1491.         Spacing := (TotalSize.X - TextSize.X) div 2
  1492.       else
  1493.         Spacing := (TotalSize.Y - TextSize.Y) div 2;
  1494.     end;
  1495.   end;
  1496.  
  1497.   case Layout of
  1498.     blGlyphLeft: begin
  1499.         GlyphPos.X := Margin;
  1500.         TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
  1501.         ArrowPos.X := TextPos.X + TextSize.X;
  1502.       end;
  1503.     blGlyphRight: begin
  1504.         ArrowPos.X := ClientSize.X - Margin - ArrowSize.X;
  1505.         GlyphPos.X := ArrowPos.X - GlyphSize.X;
  1506.         TextPos.X := GlyphPos.X - Spacing - TextSize.X;
  1507.       end;
  1508.     blGlyphTop: begin
  1509.         GlyphPos.Y := Margin;
  1510.         TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
  1511.       end;
  1512.     blGlyphBottom: begin
  1513.         GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
  1514.         TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
  1515.       end;
  1516.   end;
  1517.   Inc (ArrowPos.X);
  1518.   if not HasGlyph then
  1519.     ArrowPos.Y := TextPos.Y + (TextSize.Y - ArrowSize.Y) div 2
  1520.   else
  1521.     ArrowPos.Y := GlyphPos.Y + (GlyphSize.Y - ArrowSize.Y) div 2;
  1522.  
  1523.   { fixup the result variables }
  1524.   with GlyphPos do begin
  1525.     Inc (X, Client.Left + Offset.X);
  1526.     Inc (Y, Client.Top + Offset.Y);
  1527.   end;
  1528.   with ArrowPos do begin
  1529.     Inc (X, Client.Left + Offset.X);
  1530.     Inc (Y, Client.Top + Offset.Y);
  1531.   end;
  1532.   OffsetRect (TextBounds, TextPos.X + Client.Left + Offset.X,
  1533.     TextPos.Y + Client.Top + Offset.X);
  1534. end;
  1535.  
  1536. function TButtonGlyph.Draw (Canvas: TCanvas; const Client: TRect;
  1537.   const Offset: TPoint; DrawGlyph, DrawCaption: Boolean; const Caption: string;
  1538.   WordWrap: Boolean; Alignment: TAlignment; Layout: TButtonLayout;
  1539.   Margin, Spacing: Integer; DropArrow: Boolean; DropArrowWidth: Integer;
  1540.   State: TButtonState97): TRect;
  1541. var
  1542.   GlyphPos, ArrowPos: TPoint;
  1543. begin
  1544.   CalcButtonLayout (Canvas, Client, Offset, DrawGlyph, DrawCaption, Caption,
  1545.     WordWrap, Layout, Margin, Spacing, DropArrow, DropArrowWidth, GlyphPos,
  1546.     ArrowPos, Result);
  1547.   if DrawGlyph then
  1548.     DrawButtonGlyph (Canvas, GlyphPos, State);
  1549.   if DrawCaption then
  1550.     DrawButtonText (Canvas, Caption, Result, WordWrap, Alignment, State);
  1551.   if DropArrow then
  1552.     DrawButtonDropArrow (Canvas, ArrowPos.X, ArrowPos.Y, DropArrowWidth, State);
  1553. end;
  1554.  
  1555.  
  1556. { TDropdownList }
  1557.  
  1558. {$IFNDEF TB97D4}
  1559.  
  1560. type
  1561.   TDropdownList = class(TComponent)
  1562.   private
  1563.     List: TList;
  1564.     Window: HWND;
  1565.     procedure WndProc (var Message: TMessage);
  1566.   protected
  1567.     procedure Notification (AComponent: TComponent; Operation: TOperation); override;
  1568.   public
  1569.     constructor Create (AOwner: TComponent); override;
  1570.     destructor Destroy; override;
  1571.     procedure AddMenu (Menu: TPopupMenu);
  1572.   end;
  1573. var
  1574.   DropdownList: TDropdownList;
  1575.  
  1576. constructor TDropdownList.Create (AOwner: TComponent);
  1577. begin
  1578.   inherited;
  1579.   List := TList.Create;
  1580. end;
  1581.  
  1582. destructor TDropdownList.Destroy;
  1583. begin
  1584.   inherited;
  1585.   if Window <> 0 then
  1586.     DeallocateHWnd (Window);
  1587.   List.Free;
  1588. end;
  1589.  
  1590. procedure TDropdownList.WndProc (var Message: TMessage);
  1591. { This procedure is based on code from TPopupList.WndProc (menus.pas) }
  1592. var
  1593.   I: Integer;
  1594.   MenuItem: TMenuItem;
  1595.   FindKind: TFindItemKind;
  1596.   ContextID: Integer;
  1597. begin
  1598.   try
  1599.     with List do
  1600.       case Message.Msg of
  1601.         WM_COMMAND:
  1602.           for I := 0 to Count-1 do
  1603.             if TPopupMenu(Items[I]).DispatchCommand(TWMCommand(Message).ItemID) then
  1604.               Exit;
  1605.         WM_INITMENUPOPUP:
  1606.           for I := 0 to Count-1 do
  1607.             if TPopupMenu(Items[I]).DispatchPopup(TWMInitMenuPopup(Message).MenuPopup) then
  1608.               Exit;
  1609.         WM_MENUSELECT:
  1610.           with TWMMenuSelect(Message) do begin
  1611.             FindKind := fkCommand;
  1612.             if MenuFlag and MF_POPUP <> 0 then
  1613.               FindKind := fkHandle;
  1614.             for I := 0 to Count-1 do begin
  1615.               MenuItem := TPopupMenu(Items[I]).FindItem(IDItem, FindKind);
  1616.               if MenuItem <> nil then begin
  1617.                 Application.Hint := MenuItem.Hint;
  1618.                 Exit;
  1619.               end;
  1620.             end;
  1621.             Application.Hint := '';
  1622.           end;
  1623.         WM_HELP:
  1624.           with TWMHelp(Message).HelpInfo^ do begin
  1625.             for I := 0 to Count-1 do
  1626.               if TPopupMenu(Items[I]).Handle = hItemHandle then begin
  1627.                 ContextID := TPopupMenu(Items[I]).GetHelpContext(iCtrlID, True);
  1628.                 if ContextID = 0 then
  1629.                   ContextID := TPopupMenu(Items[I]).GetHelpContext(hItemHandle, False);
  1630.                 if Screen.ActiveForm = nil then Exit;
  1631.                 if (biHelp in Screen.ActiveForm.BorderIcons) then
  1632.                   Application.HelpCommand (HELP_CONTEXTPOPUP, ContextID)
  1633.                 else
  1634.                   Application.HelpContext (ContextID);
  1635.                 Exit;
  1636.               end;
  1637.           end;
  1638.       end;
  1639.     with Message do
  1640.       Result := DefWindowProc(Window, Msg, wParam, lParam);
  1641.   except
  1642.     Application.HandleException (Self);
  1643.   end;
  1644. end;
  1645.  
  1646. procedure TDropdownList.AddMenu (Menu: TPopupMenu);
  1647. begin
  1648.   if List.IndexOf(Menu) = -1 then begin
  1649.     if Window = 0 then
  1650.       Window := AllocateHWnd(WndProc);
  1651.     Menu.FreeNotification (Self);
  1652.     List.Add (Menu);
  1653.   end;
  1654. end;
  1655.  
  1656. procedure TDropdownList.Notification (AComponent: TComponent; Operation: TOperation);
  1657. begin
  1658.   inherited;
  1659.   if Operation = opRemove then begin
  1660.     List.Remove (AComponent);
  1661.     if (List.Count = 0) and (Window <> 0) then begin
  1662.       DeallocateHWnd (Window);
  1663.       Window := 0;
  1664.     end;
  1665.   end;
  1666. end;
  1667.  
  1668. {$ENDIF}
  1669.  
  1670.  
  1671. { TToolbarButton97 }
  1672.  
  1673. procedure ButtonHookProc (Code: THookProcCode; Wnd: HWND; WParam: WPARAM; LParam: LPARAM);
  1674. var
  1675.   P: TPoint;
  1676. begin
  1677.   case Code of
  1678.     hpSendActivateApp:
  1679.       if (WParam = 0) and Assigned(ButtonMouseInControl) and
  1680.          not ButtonMouseInControl.FShowBorderWhenInactive then
  1681.         ButtonMouseInControl.MouseLeft;
  1682.     hpPostMouseMove: begin
  1683.         if Assigned(ButtonMouseInControl) then begin
  1684.           GetCursorPos (P);
  1685.           if FindDragTarget(P, True) <> ButtonMouseInControl then
  1686.             ButtonMouseInControl.MouseLeft;
  1687.         end;
  1688.       end;
  1689.   end;
  1690. end;
  1691.  
  1692. constructor TToolbarButton97.Create (AOwner: TComponent);
  1693. begin
  1694.   inherited;
  1695.  
  1696.   if ButtonMouseTimer = nil then begin
  1697.     ButtonMouseTimer := TTimer.Create(nil);
  1698.     ButtonMouseTimer.Enabled := False;
  1699.     ButtonMouseTimer.Interval := 125;  { 8 times a second }
  1700.   end;
  1701.  
  1702.   InstallHookProc (ButtonHookProc, [hpSendActivateApp, hpPostMouseMove],
  1703.     csDesigning in ComponentState);
  1704.  
  1705.   SetBounds (Left, Top, 23, 22);
  1706.   ControlStyle := [csCaptureMouse, csDoubleClicks, csOpaque];
  1707.   Color := clBtnFace;
  1708.   FGlyph := TButtonGlyph.Create;
  1709.   TButtonGlyph(FGlyph).OnChange := GlyphChanged;
  1710.   ParentFont := True;
  1711.   FAlignment := taCenter;
  1712.   FFlat := True;
  1713.   FHighlightWhenDown := True;
  1714.   FOpaque := True;
  1715.   FSpacing := 4;
  1716.   FMargin := -1;
  1717.   FLayout := blGlyphLeft;
  1718.   FDropdownArrow := True;
  1719.   FDropdownArrowWidth := DefaultDropdownArrowWidth;
  1720.   FRepeatDelay := 400;
  1721.   FRepeatInterval := 100;
  1722.   Inc (ButtonCount);
  1723. end;
  1724.  
  1725. destructor TToolbarButton97.Destroy;
  1726. begin
  1727.   RemoveButtonMouseTimer;
  1728.   TButtonGlyph(FGlyph).Free;
  1729.   { The Notification method, which is sometimes called while the component is
  1730.     being destroyed, reads FGlyph and expects it to be valid, so it must be
  1731.     reset to nil }
  1732.   FGlyph := nil;
  1733.   UninstallHookProc (ButtonHookProc);
  1734.   Dec (ButtonCount);
  1735.   if ButtonCount = 0 then begin
  1736.     Pattern.Free;
  1737.     Pattern := nil;
  1738.     ButtonMouseTimer.Free;
  1739.     ButtonMouseTimer := nil;
  1740.   end;
  1741.   inherited;
  1742. end;
  1743.  
  1744. procedure TToolbarButton97.Paint;
  1745. const
  1746.   EdgeStyles: array[Boolean, Boolean] of UINT = (
  1747.     (EDGE_RAISED, EDGE_SUNKEN),
  1748.     (BDR_RAISEDINNER, BDR_SUNKENOUTER));
  1749.   FlagStyles: array[Boolean] of UINT = (BF_RECT or BF_SOFT or BF_MIDDLE, BF_RECT);
  1750. var
  1751.   UseBmp: Boolean;
  1752.   Bmp: TBitmap;
  1753.   DrawCanvas: TCanvas;
  1754.   PaintRect, R: TRect;
  1755.   Offset: TPoint;
  1756.   StateDownOrExclusive, DropdownComboShown, UseDownAppearance, DrawBorder: Boolean;
  1757. begin
  1758.   UseBmp := FOpaque or not FFlat;
  1759.   if UseBmp then
  1760.     Bmp := TBitmap.Create
  1761.   else
  1762.     Bmp := nil;
  1763.   try
  1764.     if UseBmp then begin
  1765.       Bmp.Width := Width;
  1766.       Bmp.Height := Height;
  1767.       DrawCanvas := Bmp.Canvas;
  1768.       with DrawCanvas do begin
  1769.         Brush.Color := Color;
  1770.         FillRect (ClientRect);
  1771.       end;
  1772.     end
  1773.     else
  1774.       DrawCanvas := Canvas;
  1775.     DrawCanvas.Font := Self.Font;
  1776.     PaintRect := Rect(0, 0, Width, Height);
  1777.  
  1778.     StateDownOrExclusive := FState in [bsDown, bsExclusive];
  1779.     DropdownComboShown := FDropdownCombo and FUsesDropdown;
  1780.     UseDownAppearance := (FState = bsExclusive) or
  1781.       ((FState = bsDown) and (not DropdownComboShown or not FMenuIsDown));
  1782.     DrawBorder := (csDesigning in ComponentState) or
  1783.       (not FNoBorder and (not FFlat or StateDownOrExclusive or (FMouseInControl and (FState <> bsDisabled))));
  1784.  
  1785.     if DropdownComboShown then begin
  1786.       if DrawBorder then begin
  1787.         R := PaintRect;
  1788.         Dec (R.Right, DropdownComboSpace);
  1789.         R.Left := R.Right - DropdownArrowWidth;
  1790.         DrawEdge (DrawCanvas.Handle, R,
  1791.           EdgeStyles[FFlat, StateDownOrExclusive and FMenuIsDown],
  1792.           FlagStyles[FFlat]);
  1793.       end;
  1794.       Dec (PaintRect.Right, DropdownArrowWidth + DropdownComboSpace);
  1795.     end;
  1796.     if DrawBorder then
  1797.       DrawEdge (DrawCanvas.Handle, PaintRect, EdgeStyles[FFlat, UseDownAppearance],
  1798.         FlagStyles[FFlat]);
  1799.     if not FNoBorder then begin
  1800.       if FFlat then
  1801.         InflateRect (PaintRect, -1, -1)
  1802.       else
  1803.         InflateRect (PaintRect, -2, -2);
  1804.     end;
  1805.  
  1806.     if UseDownAppearance then begin
  1807.       if (FState = bsExclusive) and (not FFlat or not FMouseInControl) and
  1808.          not FMenuIsDown and FHighlightWhenDown then begin
  1809.         if Pattern = nil then CreateBrushPattern;
  1810.         DrawCanvas.Brush.Bitmap := Pattern;
  1811.         DrawCanvas.FillRect(PaintRect);
  1812.       end;
  1813.       Offset.X := 1;
  1814.       Offset.Y := 1;
  1815.     end
  1816.     else begin
  1817.       Offset.X := 0;
  1818.       Offset.Y := 0;
  1819.     end;
  1820.  
  1821.     TButtonGlyph(FGlyph).Draw (DrawCanvas, PaintRect, Offset,
  1822.       FDisplayMode <> dmTextOnly, FDisplayMode <> dmGlyphOnly,
  1823.       Caption, FWordWrap, FAlignment, FLayout, FMargin, FSpacing,
  1824.       FDropdownArrow and not FDropdownCombo and FUsesDropdown,
  1825.       DropdownArrowWidth, FState);
  1826.     if DropdownComboShown then
  1827.       TButtonGlyph(FGlyph).DrawButtonDropArrow (DrawCanvas, Width-DropdownArrowWidth-2,
  1828.         Height div 2 - 1, DropdownArrowWidth, FState);
  1829.  
  1830.     if UseBmp then
  1831.       Canvas.Draw (0, 0, Bmp);
  1832.   finally
  1833.     Bmp.Free;
  1834.   end;
  1835. end;
  1836.  
  1837. procedure TToolbarButton97.RemoveButtonMouseTimer;
  1838. begin
  1839.   if ButtonMouseInControl = Self then begin
  1840.     ButtonMouseTimer.Enabled := False;
  1841.     ButtonMouseInControl := nil;
  1842.   end;
  1843. end;
  1844.  
  1845. (* no longer used
  1846. procedure TToolbarButton97.UpdateTracking;
  1847. var
  1848.   P: TPoint;
  1849. begin
  1850.   if Enabled then begin
  1851.     GetCursorPos (P);
  1852.     { Use FindDragTarget instead of PtInRect since we want to check based on
  1853.       the Z order }
  1854.     FMouseInControl := not (FindDragTarget(P, True) = Self);
  1855.     if FMouseInControl then
  1856.       MouseLeft
  1857.     else
  1858.       MouseEntered;
  1859.   end;
  1860. end;
  1861. *)
  1862.  
  1863. procedure TToolbarButton97.Loaded;
  1864. var
  1865.   State: TButtonState97;
  1866. begin
  1867.   inherited;
  1868.   if Enabled then
  1869.     State := bsUp
  1870.   else
  1871.     State := bsDisabled;
  1872.   TButtonGlyph(FGlyph).CreateButtonGlyph (State);
  1873. end;
  1874.  
  1875. procedure TToolbarButton97.Notification (AComponent: TComponent; Operation: TOperation);
  1876. begin
  1877.   inherited;
  1878.   if Operation = opRemove then begin
  1879.     if AComponent = DropdownMenu then DropdownMenu := nil;
  1880.     if Assigned(FGlyph) and (AComponent = Images) then Images := nil;
  1881.   end;
  1882. end;
  1883.  
  1884. function TToolbarButton97.PointInButton (X, Y: Integer): Boolean;
  1885. begin
  1886.   Result := (X >= 0) and
  1887.     (X < ClientWidth-((DropdownArrowWidth+DropdownComboSpace) * Ord(FDropdownCombo and FUsesDropdown))) and
  1888.     (Y >= 0) and (Y < ClientHeight);
  1889. end;
  1890.  
  1891. procedure TToolbarButton97.MouseDown (Button: TMouseButton; Shift: TShiftState;
  1892.   X, Y: Integer);
  1893. begin
  1894.   if not Enabled then begin
  1895.     inherited;
  1896.     Exit;
  1897.   end;
  1898.   if Button <> mbLeft then begin
  1899.     MouseEntered;
  1900.     inherited;
  1901.   end
  1902.   else begin
  1903.     { We know mouse has to be over the control if the mouse went down. }
  1904.     MouseEntered;
  1905.     FMenuIsDown := FUsesDropdown and (not FDropdownCombo or
  1906.       (X >= Width-(DropdownArrowWidth+DropdownComboSpace)));
  1907.     try
  1908.       if not FDown then begin
  1909.         FState := bsDown;
  1910.         Redraw (True);
  1911.       end
  1912.       else
  1913.         if FAllowAllUp then
  1914.           Redraw (True);
  1915.       if not FMenuIsDown then
  1916.         FMouseIsDown := True;
  1917.       inherited;
  1918.       if FMenuIsDown then
  1919.         Click
  1920.       else
  1921.         if FRepeating then begin
  1922.           Click;
  1923.           if not Assigned(FRepeatTimer) then
  1924.             FRepeatTimer := TTimer.Create(Self);
  1925.           FRepeatTimer.Enabled := False;
  1926.           FRepeatTimer.Interval := FRepeatDelay;
  1927.           FRepeatTimer.OnTimer := RepeatTimerHandler;
  1928.           FRepeatTimer.Enabled := True;
  1929.         end;
  1930.     finally
  1931.       FMenuIsDown := False;
  1932.     end;
  1933.   end;
  1934. end;
  1935.  
  1936. procedure TToolbarButton97.MouseMove (Shift: TShiftState; X, Y: Integer);
  1937. var
  1938.   P: TPoint;
  1939.   NewState: TButtonState97;
  1940.   PtInButton: Boolean;
  1941. begin
  1942.   inherited;
  1943.  
  1944.   { Check if mouse just entered the control. It works better to check this
  1945.     in MouseMove rather than using CM_MOUSEENTER, since the VCL doesn't send
  1946.     a CM_MOUSEENTER in all cases
  1947.     Use FindDragTarget instead of PtInRect since we want to check based on
  1948.     the Z order }
  1949.   P := ClientToScreen(Point(X, Y));
  1950.   if (ButtonMouseInControl <> Self) and (FindDragTarget(P, True) = Self) then begin
  1951.     if Assigned(ButtonMouseInControl) then
  1952.       ButtonMouseInControl.MouseLeft;
  1953.     { Like Office 97, only draw the active borders when the application is active }
  1954.     if FShowBorderWhenInactive or ApplicationIsActive then begin
  1955.       ButtonMouseInControl := Self;
  1956.       ButtonMouseTimer.OnTimer := ButtonMouseTimerHandler;
  1957.       ButtonMouseTimer.Enabled := True;
  1958.       MouseEntered;
  1959.     end;
  1960.   end;
  1961.  
  1962.   if FMouseIsDown then begin
  1963.     PtInButton := PointInButton(X, Y);
  1964.     if PtInButton and Assigned(FRepeatTimer) then
  1965.       FRepeatTimer.Enabled := True;
  1966.     if FDown then
  1967.       NewState := bsExclusive
  1968.     else begin
  1969.       if PtInButton then
  1970.         NewState := bsDown
  1971.       else
  1972.         NewState := bsUp;
  1973.     end;
  1974.     if NewState <> FState then begin
  1975.       FState := NewState;
  1976.       Redraw (True);
  1977.     end;
  1978.   end;
  1979. end;
  1980.  
  1981. procedure TToolbarButton97.RepeatTimerHandler (Sender: TObject);
  1982. var
  1983.   P: TPoint;
  1984. begin
  1985.   FRepeatTimer.Interval := FRepeatInterval;
  1986.   GetCursorPos (P);
  1987.   P := ScreenToClient(P);
  1988.   if Repeating and FMouseIsDown and MouseCapture and PointInButton(P.X, P.Y) then
  1989.     Click
  1990.   else
  1991.     FRepeatTimer.Enabled := False;
  1992. end;
  1993.  
  1994. procedure TToolbarButton97.WMCancelMode (var Message: TWMCancelMode);
  1995. begin
  1996.   FRepeatTimer.Free;
  1997.   FRepeatTimer := nil;
  1998.   if FMouseIsDown then begin
  1999.     FMouseIsDown := False;
  2000.     MouseLeft;
  2001.   end;
  2002.   { Delphi's default processing of WM_CANCELMODE sends a "fake" WM_LBUTTONUP
  2003.     message to the control, so inherited must only be called after setting
  2004.     FMouseIsDown to False }
  2005.   inherited;
  2006. end;
  2007.  
  2008. procedure TToolbarButton97.MouseUp (Button: TMouseButton; Shift: TShiftState;
  2009.   X, Y: Integer);
  2010. begin
  2011.   FRepeatTimer.Free;
  2012.   FRepeatTimer := nil;
  2013.   { Remove active border when right button is clicked }
  2014.   if (Button = mbRight) and Enabled then begin
  2015.     FMouseIsDown := False;
  2016.     MouseLeft;
  2017.   end;
  2018.   inherited;
  2019.   if (Button = mbLeft) and FMouseIsDown then begin
  2020.     FMouseIsDown := False;
  2021.     if PointInButton(X, Y) and not FRepeating then
  2022.       Click
  2023.     else
  2024.       MouseLeft;
  2025.   end;
  2026. end;
  2027.  
  2028. procedure TToolbarButton97.Click;
  2029. {$IFNDEF TB97D4}
  2030. const
  2031.   { TPM_RIGHTBUTTON works better on Windows 3.x }
  2032.   ButtonFlags: array[Boolean] of UINT = (TPM_RIGHTBUTTON, TPM_LEFTBUTTON);
  2033.   AlignFlags: array[TPopupAlignment] of UINT = (TPM_LEFTALIGN, TPM_RIGHTALIGN,
  2034.     TPM_CENTERALIGN);
  2035. {$ENDIF}
  2036. var
  2037.   Popup, ShowMenu, RemoveClicks: Boolean;
  2038.   SaveAlignment: TPopupAlignment;
  2039.   {$IFDEF TB97D4}
  2040.   SaveTrackButton: TTrackButton;
  2041.   {$ENDIF}
  2042.   PopupPt: TPoint;
  2043.   RepostList: TList; {pointers to TMsg's}
  2044.   Msg: TMsg;
  2045.   Repost: Boolean;
  2046.   I: Integer;
  2047.   P: TPoint;
  2048.   Form: {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF};
  2049.   DockPos: TGetToolbarDockPosType;
  2050. begin
  2051.   if FRepeating and not FMenuIsDown then begin
  2052.     inherited;
  2053.     Exit;
  2054.   end;
  2055.   FInClick := True;
  2056.   try
  2057.     if (GroupIndex <> 0) and not FMenuIsDown then
  2058.       SetDown (not FDown);
  2059.  
  2060.     Popup := FUsesDropdown and (not FDropdownCombo or FMenuIsDown);
  2061.     if ButtonsStayDown or Popup then begin
  2062.       if FState in [bsUp, bsMouseIn] then begin
  2063.         FState := bsDown;
  2064.         Redraw (True);
  2065.       end;
  2066.     end
  2067.     else begin
  2068.       if FState = bsDown then begin
  2069.         if FDown and (FGroupIndex <> 0) then
  2070.           FState := bsExclusive
  2071.         else
  2072.           FState := bsUp;
  2073.         Redraw (True);
  2074.       end;
  2075.     end;
  2076.  
  2077.     { Stop tracking }
  2078.     MouseLeft;
  2079.     if not Popup then begin
  2080.       Form := GetParentForm(Self);
  2081.       if Form <> nil then Form.ModalResult := ModalResult;
  2082.       inherited;
  2083.     end
  2084.     else begin
  2085.       if not FDropdownCombo then
  2086.         inherited;
  2087.       { It must release its capture before displaying the popup menu since
  2088.         this control uses csCaptureMouse. If it doesn't, the VCL seems to
  2089.         get confused and think the mouse is still captured even after the
  2090.         popup menu is displayed, causing mouse problems after the menu is
  2091.         dismissed. }
  2092.       MouseCapture := False;
  2093.       ShowMenu := Assigned(FDropdownMenu);
  2094.       RemoveClicks := True;
  2095.       if Assigned(FOnDropdown) then
  2096.         FOnDropdown (Self, ShowMenu, RemoveClicks);
  2097.       try
  2098.         if Assigned(FDropdownMenu) and ShowMenu then begin
  2099.           SaveAlignment := DropdownMenu.Alignment;
  2100.           {$IFDEF TB97D4}
  2101.           SaveTrackButton := DropdownMenu.TrackButton;
  2102.           {$ENDIF}
  2103.           try
  2104.             DropdownMenu.Alignment := paLeft;
  2105.             PopupPt := Point(0, Height);
  2106.             if Assigned(GetToolbarDockPosProc) then begin
  2107.               DockPos := GetToolbarDockPosProc(Parent);
  2108.               { Drop out right or left side }
  2109.               case DockPos of
  2110.                 gtpLeft: PopupPt := Point(Width, 0);
  2111.                 gtpRight: begin
  2112.                     PopupPt := Point(0, 0);
  2113.                     DropdownMenu.Alignment := paRight;
  2114.                   end;
  2115.               end;
  2116.             end;
  2117.             PopupPt := ClientToScreen(PopupPt);
  2118.             with DropdownMenu do begin
  2119.               PopupComponent := Self;
  2120.               { In Delphi versions prior to 4 it avoids using the Popup method
  2121.                 of TPopupMenu because it always uses the "track right button"
  2122.                 flag (which disallowed the "click and drag" selecting motion many
  2123.                 people are accustomed to). Delphi 4 has a TrackButton property
  2124.                 to control the tracking button, so it can use the Popup method. }
  2125.               {$IFNDEF TB97D4}
  2126.               if (ClassType = TPopupMenu) and Assigned(DropdownList) then begin
  2127.                 if Assigned(OnPopup) then
  2128.                   OnPopup (DropdownMenu);
  2129.                 TrackPopupMenu (Handle, AlignFlags[Alignment] or ButtonFlags[NewStyleControls],
  2130.                   PopupPt.X, PopupPt.Y, 0, DropdownList.Window, nil)
  2131.               end
  2132.               else begin
  2133.               {$ELSE}
  2134.                 if NewStyleControls then
  2135.                   TrackButton := tbLeftButton
  2136.                 else
  2137.                   TrackButton := tbRightButton;
  2138.               {$ENDIF}
  2139.                 Popup (PopupPt.X, PopupPt.Y);
  2140.               {$IFNDEF TB97D4}
  2141.               end;
  2142.               {$ENDIF}
  2143.             end;
  2144.           finally
  2145.             DropdownMenu.Alignment := SaveAlignment;
  2146.             {$IFDEF TB97D4}
  2147.             DropdownMenu.TrackButton := SaveTrackButton;
  2148.             {$ENDIF}
  2149.           end;
  2150.         end;
  2151.       finally
  2152.         if RemoveClicks then begin
  2153.           { To prevent a mouse click from redisplaying the menu, filter all
  2154.             mouse up/down messages, and repost the ones that don't need
  2155.             removing. This is sort of bulky, but it's the only way I could
  2156.             find that works perfectly and like Office 97. }
  2157.           RepostList := TList.Create;
  2158.           try
  2159.             while PeekMessage(Msg, 0, WM_LBUTTONDOWN, WM_MBUTTONDBLCLK,
  2160.                PM_REMOVE or PM_NOYIELD) do
  2161.                { ^ The WM_LBUTTONDOWN to WM_MBUTTONDBLCLK range encompasses all
  2162.                  of the DOWN and DBLCLK messages for the three buttons }
  2163.               with Msg do begin
  2164.                 Repost := True;
  2165.                 case Message of
  2166.                   WM_QUIT: begin
  2167.                       { Throw back any WM_QUIT messages }
  2168.                       PostQuitMessage (wParam);
  2169.                       Break;
  2170.                     end;
  2171.                   WM_LBUTTONDOWN, WM_LBUTTONDBLCLK,
  2172.                   WM_RBUTTONDOWN, WM_RBUTTONDBLCLK,
  2173.                   WM_MBUTTONDOWN, WM_MBUTTONDBLCLK: begin
  2174.                       P := SmallPointToPoint(TSmallPoint(lParam));
  2175.                       Windows.ClientToScreen (hwnd, P);
  2176.                       if FindDragTarget(P, True) = Self then
  2177.                         Repost := False;
  2178.                     end;
  2179.                 end;
  2180.                 if Repost then begin
  2181.                   RepostList.Add (AllocMem(SizeOf(TMsg)));
  2182.                   PMsg(RepostList.Last)^ := Msg;
  2183.                 end;
  2184.               end;
  2185.           finally
  2186.             for I := 0 to RepostList.Count-1 do begin
  2187.               with PMsg(RepostList[I])^ do
  2188.                 PostMessage (hwnd, message, wParam, lParam);
  2189.               FreeMem (RepostList[I]);
  2190.             end;
  2191.             RepostList.Free;
  2192.           end;
  2193.         end;
  2194.       end;
  2195.     end;
  2196.   finally
  2197.     FInClick := False;
  2198.     if FState = bsDown then
  2199.       FState := bsUp;
  2200.     { Need to check if it's destroying in case the OnClick handler freed
  2201.       the button. If it doesn't check this here, it can sometimes cause an
  2202.       access violation }
  2203.     if not(csDestroying in ComponentState) then begin
  2204.       Redraw (True);
  2205.       MouseLeft;
  2206.     end;
  2207.   end;
  2208. end;
  2209.  
  2210. function TToolbarButton97.GetPalette: HPALETTE;
  2211. begin
  2212.   Result := Glyph.Palette;
  2213. end;
  2214.  
  2215. function TToolbarButton97.GetGlyph: TBitmap;
  2216. begin
  2217.   Result := TButtonGlyph(FGlyph).Glyph;
  2218. end;
  2219.  
  2220. procedure TToolbarButton97.SetGlyph (Value: TBitmap);
  2221. begin
  2222.   TButtonGlyph(FGlyph).Glyph := Value;
  2223.   Redraw (True);
  2224. end;
  2225.  
  2226. function TToolbarButton97.GetGlyphMask: TBitmap;
  2227. begin
  2228.   Result := TButtonGlyph(FGlyph).GlyphMask;
  2229. end;
  2230.  
  2231. procedure TToolbarButton97.SetGlyphMask (Value: TBitmap);
  2232. begin
  2233.   TButtonGlyph(FGlyph).GlyphMask := Value;
  2234.   Redraw (True);
  2235. end;
  2236.  
  2237. procedure TToolbarButton97.SetHighlightWhenDown (Value: Boolean);
  2238. begin
  2239.   if FHighlightWhenDown <> Value then begin
  2240.     FHighlightWhenDown := Value;
  2241.     if Down then
  2242.       Redraw (True);
  2243.   end;
  2244. end;
  2245.  
  2246. function TToolbarButton97.GetImageIndex: Integer;
  2247. begin
  2248.   Result := TButtonGlyph(FGlyph).FImageIndex;
  2249. end;
  2250.  
  2251. procedure TToolbarButton97.SetImageIndex (Value: Integer);
  2252. begin
  2253.   if TButtonGlyph(FGlyph).FImageIndex <> Value then begin
  2254.     TButtonGlyph(FGlyph).FImageIndex := Value;
  2255.     if Assigned(TButtonGlyph(FGlyph).FImageList) then
  2256.       TButtonGlyph(FGlyph).GlyphChanged (nil);
  2257.   end;
  2258. end;
  2259.  
  2260. function TToolbarButton97.GetImages: TCustomImageList;
  2261. begin
  2262.   Result := TButtonGlyph(FGlyph).FImageList;
  2263. end;
  2264.  
  2265. procedure TToolbarButton97.SetImages (Value: TCustomImageList);
  2266. begin
  2267.   with TButtonGlyph(FGlyph) do
  2268.     if FImageList <> Value then begin
  2269.       if FImageList <> nil then
  2270.         FImageList.UnRegisterChanges (FImageChangeLink);
  2271.       FImageList := Value;
  2272.       if FImageList <> nil then begin
  2273.         if FImageChangeLink = nil then begin
  2274.           FImageChangeLink := TChangeLink.Create;
  2275.           FImageChangeLink.OnChange := GlyphChanged;
  2276.         end;
  2277.         FImageList.RegisterChanges (FImageChangeLink);
  2278.         FImageList.FreeNotification (Self);
  2279.       end
  2280.       else begin
  2281.         FImageChangeLink.Free;
  2282.         FImageChangeLink := nil;
  2283.       end;
  2284.       UpdateNumGlyphs;
  2285.     end;
  2286. end;
  2287.  
  2288. function TToolbarButton97.GetNumGlyphs: TNumGlyphs97;
  2289. begin
  2290.   Result := TButtonGlyph(FGlyph).NumGlyphs;
  2291. end;
  2292.  
  2293. procedure TToolbarButton97.SetNumGlyphs (Value: TNumGlyphs97);
  2294. begin
  2295.   if Value < Low(TNumGlyphs97) then
  2296.     Value := Low(TNumGlyphs97)
  2297.   else
  2298.   if Value > High(TNumGlyphs97) then
  2299.     Value := High(TNumGlyphs97);
  2300.   if Value <> TButtonGlyph(FGlyph).NumGlyphs then begin
  2301.     TButtonGlyph(FGlyph).NumGlyphs := Value;
  2302.     Redraw (True);
  2303.   end;
  2304. end;
  2305.  
  2306. procedure TToolbarButton97.GlyphChanged(Sender: TObject);
  2307. begin
  2308.   Redraw (True);
  2309. end;
  2310.  
  2311. procedure TToolbarButton97.UpdateExclusive;
  2312. var
  2313.   I: Integer;
  2314.   Ctl: TControl;
  2315. begin
  2316.   if (FGroupIndex <> 0) and (Parent <> nil) then
  2317.     with Parent do
  2318.       for I := 0 to ControlCount-1 do begin
  2319.         Ctl := Controls[I];
  2320.         if (Ctl <> Self) and (Ctl is TToolbarButton97) then
  2321.           with TToolbarButton97(Ctl) do
  2322.             if FGroupIndex = Self.FGroupIndex then begin
  2323.               if Self.Down and FDown then begin
  2324.                 FDown := False;
  2325.                 FState := bsUp;
  2326.                 Redraw (True);
  2327.               end;
  2328.               FAllowAllUp := Self.AllowAllUp;
  2329.             end;
  2330.       end;
  2331. end;
  2332.  
  2333. procedure TToolbarButton97.SetDown (Value: Boolean);
  2334. begin
  2335.   if FGroupIndex = 0 then
  2336.     Value := False;
  2337.   if Value <> FDown then begin
  2338.     if FDown and (not FAllowAllUp) then Exit;
  2339.     FDown := Value;
  2340.     if not Enabled then
  2341.       FState := bsDisabled
  2342.     else begin
  2343.       if Value then
  2344.         FState := bsExclusive
  2345.       else
  2346.         FState := bsUp;
  2347.     end;
  2348.     Redraw (True);
  2349.     if Value then UpdateExclusive;
  2350.   end;
  2351. end;
  2352.  
  2353. procedure TToolbarButton97.SetFlat (Value: Boolean);
  2354. begin
  2355.   if FFlat <> Value then begin
  2356.     FFlat := Value;
  2357.     if FOpaque or not FFlat then
  2358.       ControlStyle := ControlStyle + [csOpaque]
  2359.     else
  2360.       ControlStyle := ControlStyle - [csOpaque];
  2361.     Redraw (True);
  2362.   end;
  2363. end;
  2364.  
  2365. procedure TToolbarButton97.SetGroupIndex (Value: Integer);
  2366. begin
  2367.   if FGroupIndex <> Value then begin
  2368.     FGroupIndex := Value;
  2369.     UpdateExclusive;
  2370.   end;
  2371. end;
  2372.  
  2373. procedure TToolbarButton97.SetLayout (Value: TButtonLayout);
  2374. begin
  2375.   if FLayout <> Value then begin
  2376.     FLayout := Value;
  2377.     Redraw (True);
  2378.   end;
  2379. end;
  2380.  
  2381. procedure TToolbarButton97.SetMargin (Value: Integer);
  2382. begin
  2383.   if (FMargin <> Value) and (Value >= -1) then begin
  2384.     FMargin := Value;
  2385.     Redraw (True);
  2386.   end;
  2387. end;
  2388.  
  2389. procedure TToolbarButton97.SetNoBorder (Value: Boolean);
  2390. begin
  2391.   if FNoBorder <> Value then begin
  2392.     FNoBorder := Value;
  2393.     Invalidate;
  2394.   end;
  2395. end;
  2396.  
  2397. procedure TToolbarButton97.SetOldDisabledStyle (Value: Boolean);
  2398. begin
  2399.   if FOldDisabledStyle <> Value then begin
  2400.     FOldDisabledStyle := Value;
  2401.     with TButtonGlyph(FGlyph) do begin
  2402.       FOldDisabledStyle := Value;
  2403.       Invalidate;
  2404.     end;
  2405.     Redraw (True);
  2406.   end;
  2407. end;
  2408.  
  2409. procedure TToolbarButton97.SetOpaque (Value: Boolean);
  2410. begin
  2411.   if FOpaque <> Value then begin
  2412.     FOpaque := Value;
  2413.     if FOpaque or not FFlat then
  2414.       ControlStyle := ControlStyle + [csOpaque]
  2415.     else
  2416.       ControlStyle := ControlStyle - [csOpaque];
  2417.     Invalidate;
  2418.   end;
  2419. end;
  2420.  
  2421. procedure TToolbarButton97.Redraw (const Erase: Boolean);
  2422. var
  2423.   AddedOpaque: Boolean;
  2424. begin
  2425.   if FOpaque or not FFlat or not Erase then begin
  2426.     { Temporarily add csOpaque to the style. This prevents Invalidate from
  2427.       erasing, which isn't needed when Erase is false. }
  2428.     AddedOpaque := False;
  2429.     if not(csOpaque in ControlStyle) then begin
  2430.       AddedOpaque := True;
  2431.       ControlStyle := ControlStyle + [csOpaque];
  2432.     end;
  2433.     try
  2434.       Invalidate;
  2435.     finally
  2436.       if AddedOpaque then
  2437.         ControlStyle := ControlStyle - [csOpaque];
  2438.     end;
  2439.   end
  2440.   else
  2441.   if not(FOpaque or not FFlat) then
  2442.     Invalidate;
  2443. end;
  2444.  
  2445. procedure TToolbarButton97.SetSpacing (Value: Integer);
  2446. begin
  2447.   if Value <> FSpacing then begin
  2448.     FSpacing := Value;
  2449.     Redraw (True);
  2450.   end;
  2451. end;
  2452.  
  2453. procedure TToolbarButton97.SetAllowAllUp (Value: Boolean);
  2454. begin
  2455.   if FAllowAllUp <> Value then begin
  2456.     FAllowAllUp := Value;
  2457.     UpdateExclusive;
  2458.   end;
  2459. end;
  2460.  
  2461. procedure TToolbarButton97.SetDropdownMenu (Value: TPopupMenu);
  2462. var
  2463.   NewUsesDropdown: Boolean;
  2464. begin
  2465.   if FDropdownMenu <> Value then begin
  2466.     FDropdownMenu := Value;
  2467.     if Assigned(Value) then begin
  2468.       Value.FreeNotification (Self);
  2469.       {$IFNDEF TB97D4}
  2470.       if DropdownList = nil then
  2471.         DropdownList := TDropdownList.Create(nil);
  2472.       DropdownList.AddMenu (Value);
  2473.       {$ENDIF}
  2474.     end;
  2475.     NewUsesDropdown := FDropdownAlways or Assigned(Value);
  2476.     if FUsesDropdown <> NewUsesDropdown then begin
  2477.       FUsesDropdown := NewUsesDropdown;
  2478.       if FDropdownArrow or FDropdownCombo then
  2479.         Redraw (True);
  2480.     end;
  2481.   end;
  2482. end;
  2483.  
  2484. procedure TToolbarButton97.SetWordWrap (Value: Boolean);
  2485. begin
  2486.   if FWordWrap <> Value then begin
  2487.     FWordWrap := Value;
  2488.     Redraw (True);
  2489.   end;
  2490. end;
  2491.  
  2492. procedure TToolbarButton97.SetAlignment (Value: TAlignment);
  2493. begin
  2494.   if FAlignment <> Value then begin
  2495.     FAlignment := Value;
  2496.     Redraw (True);
  2497.   end;
  2498. end;
  2499.  
  2500. procedure TToolbarButton97.SetDropdownAlways (Value: Boolean);
  2501. var
  2502.   NewUsesDropdown: Boolean;
  2503. begin
  2504.   if FDropdownAlways <> Value then begin
  2505.     FDropdownAlways := Value;
  2506.     NewUsesDropdown := Value or Assigned(FDropdownMenu);
  2507.     if FUsesDropdown <> NewUsesDropdown then begin
  2508.       FUsesDropdown := NewUsesDropdown;
  2509.       if FDropdownArrow or FDropdownCombo then
  2510.         Redraw (True);
  2511.     end;
  2512.   end;
  2513. end;
  2514.  
  2515. procedure TToolbarButton97.SetDropdownArrow (Value: Boolean);
  2516. begin
  2517.   if FDropdownArrow <> Value then begin
  2518.     FDropdownArrow := Value;
  2519.     Redraw (True);
  2520.   end;
  2521. end;
  2522.  
  2523. procedure TToolbarButton97.SetDropdownArrowWidth (Value: Integer);
  2524. var
  2525.   Diff: Integer;
  2526. begin
  2527.   if Value < 7 then Value := 7;
  2528.   if FDropdownArrowWidth <> Value then begin
  2529.     Diff := Value - FDropdownArrowWidth;
  2530.     FDropdownArrowWidth := Value;
  2531.     if not(csLoading in ComponentState) and FDropdownCombo then
  2532.       Width := Width + Diff;
  2533.     Redraw (True);
  2534.   end;
  2535. end;
  2536.  
  2537. procedure TToolbarButton97.SetDropdownCombo (Value: Boolean);
  2538. var
  2539.   W: Integer;
  2540. begin
  2541.   if FDropdownCombo <> Value then begin
  2542.     FDropdownCombo := Value;
  2543.     if not(csLoading in ComponentState) then begin
  2544.       if Value then
  2545.         Width := Width + (DropdownArrowWidth + DropdownComboSpace)
  2546.       else begin
  2547.         W := Width - (DropdownArrowWidth + DropdownComboSpace);
  2548.         if W < 1 then W := 1;
  2549.         Width := W;
  2550.       end;
  2551.     end;
  2552.     Redraw (True);
  2553.   end;
  2554. end;
  2555.  
  2556. procedure TToolbarButton97.SetDisplayMode (Value: TButtonDisplayMode);
  2557. begin
  2558.   if FDisplayMode <> Value then begin
  2559.     FDisplayMode := Value;
  2560.     Redraw (True);
  2561.   end;
  2562. end;
  2563.  
  2564. function TToolbarButton97.GetCallDormant: Boolean;
  2565. begin
  2566.   Result := TButtonGlyph(FGlyph).FCallDormant;
  2567. end;
  2568.  
  2569. procedure TToolbarButton97.SetCallDormant (Value: Boolean);
  2570. begin
  2571.   TButtonGlyph(FGlyph).FCallDormant := Value;
  2572. end;
  2573.  
  2574. function TToolbarButton97.GetVersion: TToolbar97Version;
  2575. begin
  2576.   Result := Toolbar97VersionPropText;
  2577. end;
  2578.  
  2579. procedure TToolbarButton97.SetVersion (const Value: TToolbar97Version);
  2580. begin
  2581.   { write method required for the property to show up in Object Inspector }
  2582. end;
  2583.  
  2584. {$IFDEF TB97D4}
  2585. function TToolbarButton97.IsCheckedStored: Boolean;
  2586. begin
  2587.   Result := (ActionLink = nil) or not TToolbarButton97ActionLink(ActionLink).IsCheckedLinked;
  2588. end;
  2589.  
  2590. function TToolbarButton97.IsHelpContextStored: Boolean;
  2591. begin
  2592.   Result := (ActionLink = nil) or not TToolbarButton97ActionLink(ActionLink).IsHelpContextLinked;
  2593. end;
  2594.  
  2595. function TToolbarButton97.IsImageIndexStored: Boolean;
  2596. begin
  2597.   Result := (ActionLink = nil) or not TToolbarButton97ActionLink(ActionLink).IsImageIndexLinked;
  2598. end;
  2599.  
  2600. procedure TToolbarButton97.ActionChange (Sender: TObject; CheckDefaults: Boolean);
  2601. begin
  2602.   inherited;
  2603.   if Sender is TCustomAction then
  2604.     with TCustomAction(Sender) do
  2605.     begin
  2606.       if not CheckDefaults or (Self.Down = False) then
  2607.         Self.Down := Checked;
  2608.       if not CheckDefaults or (Self.HelpContext = 0) then
  2609.         Self.HelpContext := HelpContext;
  2610.       if not CheckDefaults or (Self.ImageIndex = -1) then
  2611.         Self.ImageIndex := ImageIndex;
  2612.     end;
  2613. end;
  2614.  
  2615. function TToolbarButton97.GetActionLinkClass: TControlActionLinkClass;
  2616. begin
  2617.   Result := TToolbarButton97ActionLink;
  2618. end;
  2619.  
  2620. procedure TToolbarButton97.AssignTo (Dest: TPersistent);
  2621. begin
  2622.   inherited;
  2623.   if Dest is TCustomAction then
  2624.     TCustomAction(Dest).Checked := Self.Down;
  2625. end;
  2626. {$ENDIF}
  2627.  
  2628. procedure TToolbarButton97.WMLButtonDblClk (var Message: TWMLButtonDblClk);
  2629. begin
  2630.   inherited;
  2631.   if FDown then DblClick;
  2632. end;
  2633.  
  2634. procedure TToolbarButton97.CMEnabledChanged (var Message: TMessage);
  2635. begin
  2636.   if not Enabled then begin
  2637.     FState := bsDisabled;
  2638.     FMouseInControl := False;
  2639.     FMouseIsDown := False;
  2640.     RemoveButtonMouseTimer;
  2641.     Perform (WM_CANCELMODE, 0, 0);
  2642.   end
  2643.   else
  2644.   if FState = bsDisabled then
  2645.     if FDown and (FGroupIndex <> 0) then
  2646.       FState := bsExclusive
  2647.     else
  2648.       FState := bsUp;
  2649.   Redraw (True);
  2650. end;
  2651.  
  2652. procedure TToolbarButton97.CMDialogChar (var Message: TCMDialogChar);
  2653. begin
  2654.   with Message do
  2655.     if IsAccel(CharCode, Caption) and Assigned(Parent) and Parent.CanFocus and
  2656.        Enabled and Visible and (DisplayMode <> dmGlyphOnly) then begin
  2657.       { NOTE: There is a bug in TSpeedButton where accelerator keys are still
  2658.         processed even when the button is not visible. The 'and Visible'
  2659.         corrects it, so TToolbarButton97 doesn't have this problem. }
  2660.       Click;
  2661.       Result := 1;
  2662.     end
  2663.     else
  2664.       inherited;
  2665. end;
  2666.  
  2667. procedure TToolbarButton97.CMDialogKey (var Message: TCMDialogKey);
  2668. begin
  2669.   with Message do
  2670.     if (((CharCode = VK_RETURN) and FDefault) or
  2671.         ((CharCode = VK_ESCAPE) and FCancel)) and
  2672.        (KeyDataToShiftState(Message.KeyData) = []) and
  2673.        Assigned(Parent) and Parent.CanFocus and Enabled and Visible then begin
  2674.       Click;
  2675.       Result := 1;
  2676.     end
  2677.     else
  2678.       inherited;
  2679. end;
  2680.  
  2681. procedure TToolbarButton97.CMFontChanged (var Message: TMessage);
  2682. begin
  2683.   Redraw (True);
  2684. end;
  2685.  
  2686. procedure TToolbarButton97.CMTextChanged (var Message: TMessage);
  2687. begin
  2688.   Redraw (True);
  2689. end;
  2690.  
  2691. procedure TToolbarButton97.CMSysColorChange (var Message: TMessage);
  2692. begin
  2693.   inherited;
  2694.   if Assigned(Pattern) and
  2695.      ((PatternBtnFace <> TColor(GetSysColor(COLOR_BTNFACE))) or
  2696.       (PatternBtnHighlight <> TColor(GetSysColor(COLOR_BTNHIGHLIGHT)))) then begin
  2697.     Pattern.Free;
  2698.     Pattern := nil;
  2699.   end;
  2700.   with TButtonGlyph(FGlyph) do begin
  2701.     Invalidate;
  2702.     CreateButtonGlyph (FState);
  2703.   end;
  2704. end;
  2705.  
  2706. procedure TToolbarButton97.MouseEntered;
  2707. begin
  2708.   if Enabled and not FMouseInControl then begin
  2709.     FMouseInControl := True;
  2710.     if FState = bsUp then
  2711.       FState := bsMouseIn;
  2712.     if FFlat or (NumGlyphs >= 5) then
  2713.       Redraw (FDown or (NumGlyphs >= 5));
  2714.     if Assigned(FOnMouseEnter) then
  2715.       FOnMouseEnter (Self);
  2716.   end;
  2717. end;
  2718.  
  2719. procedure TToolbarButton97.MouseLeft;
  2720. var
  2721.   OldState: TButtonState97;
  2722. begin
  2723.   if Enabled and FMouseInControl and not FMouseIsDown then begin
  2724.     FMouseInControl := False;
  2725.     RemoveButtonMouseTimer;
  2726.     OldState := FState;
  2727.     if (FState = bsMouseIn) or (not FInClick and (FState = bsDown)) then begin
  2728.       if FDown and (FGroupIndex <> 0) then
  2729.         FState := bsExclusive
  2730.       else
  2731.         FState := bsUp;
  2732.     end;
  2733.     if FFlat or ((NumGlyphs >= 5) or ((OldState = bsMouseIn) xor (FState <> OldState))) then
  2734.       Redraw (True);
  2735.     if Assigned(FOnMouseExit) then
  2736.       FOnMouseExit (Self);
  2737.   end;
  2738. end;
  2739.  
  2740. procedure TToolbarButton97.ButtonMouseTimerHandler (Sender: TObject);
  2741. var
  2742.   P: TPoint;
  2743. begin
  2744.   { The button mouse timer is used to periodically check if mouse has left.
  2745.     Normally it receives a CM_MOUSELEAVE, but the VCL does not send a
  2746.     CM_MOUSELEAVE if the mouse is moved quickly from the button to another
  2747.     application's window. For some reason, this problem doesn't seem to occur
  2748.     on Windows NT 4 -- only 95 and 3.x.
  2749.  
  2750.     The timer (which ticks 8 times a second) is only enabled when the
  2751.     application is active and the mouse is over a button, so it uses virtually
  2752.     no processing power.
  2753.  
  2754.     For something interesting to try: If you want to know just how often this
  2755.     is called, try putting a Beep call in here }
  2756.  
  2757.   GetCursorPos (P);
  2758.   if FindDragTarget(P, True) <> Self then
  2759.     MouseLeft;
  2760. end;
  2761.  
  2762.  
  2763. { TEdit97 - internal }
  2764.  
  2765. constructor TEdit97.Create (AOwner: TComponent);
  2766. begin
  2767.   inherited;
  2768.   AutoSize := False;
  2769.   Ctl3D := False;
  2770.   BorderStyle := bsNone;
  2771.   ControlStyle := ControlStyle - [csFramed]; {fixes a VCL bug with Win 3.x}
  2772.   Height := 19;
  2773.   if Edit97Count = 0 then
  2774.     Register97ControlClass (TEdit97);
  2775.   Inc (Edit97Count);
  2776. end;
  2777.  
  2778. destructor TEdit97.Destroy;
  2779. begin
  2780.   Dec (Edit97Count);
  2781.   if Edit97Count = 0 then
  2782.     Unregister97ControlClass (TEdit97);
  2783.   inherited;
  2784. end;
  2785.  
  2786. procedure TEdit97.CMMouseEnter (var Message: TMessage);
  2787. begin
  2788.   inherited;
  2789.   MouseInControl := True;
  2790.   DrawNCArea (False, 0, 0);
  2791. end;
  2792.  
  2793. procedure TEdit97.CMMouseLeave (var Message: TMessage);
  2794. begin
  2795.   inherited;
  2796.   MouseInControl := False;
  2797.   DrawNCArea (False, 0, 0);
  2798. end;
  2799.  
  2800. procedure TEdit97.NewAdjustHeight;
  2801. var
  2802.   DC: HDC;
  2803.   SaveFont: HFONT;
  2804.   Metrics: TTextMetric;
  2805. begin
  2806.   DC := GetDC(0);
  2807.   SaveFont := SelectObject(DC, Font.Handle);
  2808.   GetTextMetrics (DC, Metrics);
  2809.   SelectObject (DC, SaveFont);
  2810.   ReleaseDC (0, DC);
  2811.  
  2812.   Height := Metrics.tmHeight + 6;
  2813. end;
  2814.  
  2815. procedure TEdit97.Loaded;
  2816. begin
  2817.   inherited;
  2818.   if not(csDesigning in ComponentState) then
  2819.     NewAdjustHeight;
  2820. end;
  2821.  
  2822. procedure TEdit97.CMEnabledChanged (var Message: TMessage);
  2823. const
  2824.   EnableColors: array[Boolean] of TColor = (clBtnFace, clWindow);
  2825. begin
  2826.   inherited;
  2827.   Color := EnableColors[Enabled];
  2828.   { Ensure non-client area is invalidated as well }
  2829.   if HandleAllocated then
  2830.     RedrawWindow (Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_ERASE or
  2831.       RDW_NOCHILDREN);
  2832. end;
  2833.  
  2834. procedure TEdit97.CMFontChanged (var Message: TMessage);
  2835. begin
  2836.   inherited;
  2837.   if not((csDesigning in ComponentState) and (csLoading in ComponentState)) then
  2838.     NewAdjustHeight;
  2839. end;
  2840.  
  2841. procedure TEdit97.WMSetFocus (var Message: TWMSetFocus);
  2842. begin
  2843.   inherited;
  2844.   if not(csDesigning in ComponentState) then
  2845.     DrawNCArea (False, 0, 0);
  2846. end;
  2847.  
  2848. procedure TEdit97.WMKillFocus (var Message: TWMKillFocus);
  2849. begin
  2850.   inherited;
  2851.   if not(csDesigning in ComponentState) then
  2852.     DrawNCArea (False, 0, 0);
  2853. end;
  2854.  
  2855. procedure TEdit97.WMNCCalcSize (var Message: TWMNCCalcSize);
  2856. begin
  2857.   InflateRect (Message.CalcSize_Params^.rgrc[0], -3, -3);
  2858. end;
  2859.  
  2860. procedure TEdit97.WMNCPaint (var Message: TMessage);
  2861. begin
  2862.   DrawNCArea (False, 0, HRGN(Message.WParam));
  2863. end;
  2864.  
  2865. procedure TEdit97.DrawNCArea (const DrawToDC: Boolean; const ADC: HDC;
  2866.   const Clip: HRGN);
  2867. var
  2868.   DC: HDC;
  2869.   R: TRect;
  2870.   BtnFaceBrush, WindowBrush: HBRUSH;
  2871. begin
  2872.   if not DrawToDC then
  2873.     DC := GetWindowDC(Handle)
  2874.   else
  2875.     DC := ADC;
  2876.   try
  2877.     { Use update region }
  2878.     if not DrawToDC then
  2879.       SelectNCUpdateRgn (Handle, DC, Clip);
  2880.  
  2881.     { This works around WM_NCPAINT problem described at top of source code }
  2882.     {no!  R := Rect(0, 0, Width, Height);}
  2883.     GetWindowRect (Handle, R);  OffsetRect (R, -R.Left, -R.Top);
  2884.     BtnFaceBrush := GetSysColorBrush(COLOR_BTNFACE);
  2885.     WindowBrush := GetSysColorBrush(COLOR_WINDOW);
  2886.     if ((csDesigning in ComponentState) and Enabled) or
  2887.        (not(csDesigning in ComponentState) and
  2888.         (Focused or (MouseInControl and not ControlIs97Control(Screen.ActiveControl)))) then begin
  2889.       DrawEdge (DC, R, BDR_SUNKENOUTER, BF_RECT or BF_ADJUST);
  2890.       with R do begin
  2891.         FillRect (DC, Rect(Left, Top, Left+1, Bottom-1), BtnFaceBrush);
  2892.         FillRect (DC, Rect(Left, Top, Right-1, Top+1), BtnFaceBrush);
  2893.       end;
  2894.       DrawEdge (DC, R, BDR_SUNKENINNER, BF_BOTTOMRIGHT);
  2895.       InflateRect (R, -1, -1);
  2896.       FrameRect (DC, R, WindowBrush);
  2897.     end
  2898.     else begin
  2899.       FrameRect (DC, R, BtnFaceBrush);
  2900.       InflateRect (R, -1, -1);
  2901.       FrameRect (DC, R, BtnFaceBrush);
  2902.       InflateRect (R, -1, -1);
  2903.       FrameRect (DC, R, WindowBrush);
  2904.     end;
  2905.   finally
  2906.     if not DrawToDC then
  2907.       ReleaseDC (Handle, DC);
  2908.   end;
  2909. end;
  2910.  
  2911. procedure EditNCPaintProc (Wnd: HWND; DC: HDC; AppData: Longint);
  2912. begin
  2913.   TEdit97(AppData).DrawNCArea (True, DC, 0);
  2914. end;
  2915.  
  2916. procedure TEdit97.WMPrint (var Message: TMessage);
  2917. begin
  2918.   HandleWMPrint (Handle, Message, EditNCPaintProc, Longint(Self));
  2919. end;
  2920.  
  2921. procedure TEdit97.WMPrintClient (var Message: TMessage);
  2922. begin
  2923.   HandleWMPrintClient (Self, Message);
  2924. end;
  2925.  
  2926. function TEdit97.GetVersion: TToolbar97Version;
  2927. begin
  2928.   Result := Toolbar97VersionPropText;
  2929. end;
  2930.  
  2931. procedure TEdit97.SetVersion (const Value: TToolbar97Version);
  2932. begin
  2933.   { write method required for the property to show up in Object Inspector }
  2934. end;
  2935.  
  2936.  
  2937. {$IFNDEF TB97D4}
  2938. initialization
  2939. finalization
  2940.   DropdownList.Free;
  2941. {$ENDIF}
  2942. end.
  2943.