View Issue Details

IDProjectCategoryView StatusLast Update
0036678LazarusOtherpublic2020-02-20 15:17
Reporterzhangch2010Assigned To 
PrioritynormalSeverityminorReproducibilityalways
Status newResolutionopen 
Product VersionProduct Build 
Target VersionFixed in Version 
Summary0036678: BitButton leaks GDI objects / 多次打开窗体关闭后bitbtn异常
Description一个窗体重复测试 打开 关闭,300+次后出现bitbtn异常
--
When a form gets repeatedly opened and closed in attached test, bitbtn exception occurs after 300+ times of opening/closing.
TagsNo tags attached.
Fixed in Revision
LazTarget-
WidgetsetWin32/Win64
Attached Files
  • demo.zip (583,405 bytes)
  • ok.PNG (149,054 bytes)
    ok.PNG (149,054 bytes)
  • NG.PNG (130,800 bytes)
    NG.PNG (130,800 bytes)
  • pic1.PNG (46,636 bytes)
    pic1.PNG (46,636 bytes)
  • ok-2.PNG (127,447 bytes)
    ok-2.PNG (127,447 bytes)
  • bitbtn.inc (11,125 bytes)
    {%MainUnit ../buttons.pp}
    
    {
     *****************************************************************************
      This file is part of the Lazarus Component Library (LCL)
    
      See the file COPYING.modifiedLGPL.txt, included in this distribution,
      for details about the license.
     *****************************************************************************
    }
    
    {------------------------------------------------------------------------------
           TCustomBitBtn Constructor
    ------------------------------------------------------------------------------}
    constructor TCustomBitBtn.Create(TheOwner: TComponent);
    begin
      inherited Create(TheOwner);
      FCompStyle := csBitBtn;
      FDefaultCaption := False;
      FKind := bkCustom;
      FLayout := blGlyphLeft;
      FSpacing := 4;
      FMargin := -1;
      FButtonGlyph := TButtonGlyph.Create;
      FButtonGlyph.NumGlyphs := 1;
      FButtonGlyph.OnChange := @GlyphChanged;
      FButtonGlyph.IsDesigning := csDesigning in ComponentState;
      FImageChangeLink := TChangeLink.Create;
      FImageChangeLink.OnChange := @ImageListChange;
      Align := alNone;
    end;
    
    {------------------------------------------------------------------------------
           TCustomBitBtn destructor
    ------------------------------------------------------------------------------}
    destructor TCustomBitBtn.Destroy;
    begin
      FreeAndNil(FButtonGlyph);
      FreeAndNil(FImageChangeLink);
      FreeAndNil(BitBtnImages);
      
       //2020-02-08 zhangch2010
      if NewBitmap <>0 then begin
        DeleteObject(NewBitmap);
        end;
    
      inherited Destroy;
    end;
    
    procedure TCustomBitBtn.Click;
    var
      Form : TCustomForm;
    begin
      { A TBitBtn with Kind = bkClose should
        - Close the ParentForm if ModalResult = mrNone.
          It should not set ParentForm.ModalResult in this case
        - Close a non-modal ParentForm if ModalResult in [mrNone, mrClose]
        - on nested forms it will close the non docked form
        - In all other cases it should behave like any other TBitBtn
      }
      if (FKind = bkClose) then
      begin
        Form := GetTopFormSkipNonDocked(Self);
        if (Form <> nil) then
        begin
          if (ModalResult = mrNone) or
             ((ModalResult = mrClose) and not (fsModal in Form.FormState)) then
          begin
            Form.Close;
            Exit;
          end;
        end;
      end;
      inherited Click;
    end;
    
    procedure TCustomBitBtn.LoadGlyphFromResourceName(Instance: THandle; const AName: String);
    begin
      Buttons.LoadGlyphFromResourceName(FButtonGlyph, Instance, AName);
    end;
    
    procedure TCustomBitBtn.LoadGlyphFromLazarusResource(const AName: String);
    begin
      Buttons.LoadGlyphFromLazarusResource(FButtonGlyph, AName);
    end;
    
    procedure TCustomBitBtn.LoadGlyphFromStock(idButton: Integer);
    begin
      Buttons.LoadGlyphFromStock(FButtonGlyph, idButton);
    end;
    
    procedure TCustomBitBtn.Notification(AComponent: TComponent;
      Operation: TOperation);
    begin
      inherited Notification(AComponent, Operation);
      if (Operation = opRemove) and (FButtonGlyph <> nil) and (AComponent = FButtonGlyph.ExternalImages) then
        Images := nil;
    end;
    
    function TCustomBitBtn.CanShowGlyph(const AWithShowMode: Boolean): Boolean;
    begin
      Result := FButtonGlyph.CanShowGlyph;
      if AWithShowMode then
        Result := Result and FButtonGlyph.CanShow;
    end;
    
    function TCustomBitBtn.GetGlyph : TBitmap;
    begin
      Result := FButtonGlyph.Glyph;
    end;
    
    function TCustomBitBtn.GetGlyphShowMode: TGlyphShowMode;
    begin
      Result := FButtonGlyph.ShowMode;
    end;
    
    function TCustomBitBtn.GetImageIndex: TImageIndex;
    begin
      Result := FButtonGlyph.ExternalImageIndex;
    end;
    
    function TCustomBitBtn.GetImages: TCustomImageList;
    begin
      Result := FButtonGlyph.ExternalImages;
    end;
    
    function TCustomBitBtn.GetImageWidth: Integer;
    begin
      Result := FButtonGlyph.ExternalImageWidth;
    end;
    
    function TCustomBitBtn.GetNumGlyphs: Integer;
    begin
      Result := FButtonGlyph.FNumGlyphs;
    end;
    
    function TCustomBitBtn.IsGlyphStored: Boolean;
    var
      act: TCustomAction;
    begin
      if Action <> nil then
      begin
        result := true;
        act := TCustomAction(Action);
        if (act.ActionList <> nil) and (act.ActionList.Images <> nil) and
          (act.ImageIndex >= 0) and (act.ImageIndex < act.ActionList.Images.Count) then
            result := false;
      end 
      else Result := (Kind = bkCustom) and (FButtonGlyph.Glyph <> nil)
        and (not FButtonGlyph.Glyph.Empty)
          and (FButtonGlyph.Glyph.Width>0) and (FButtonGlyph.Glyph.Height>0);
    end;
    
    procedure TCustomBitBtn.SetGlyph(AValue: TBitmap);
    begin
      FButtonGlyph.Glyph := AValue;
      InvalidatePreferredSize;
      AdjustSize;
    end;
    
    procedure TCustomBitBtn.SetGlyphShowMode(const AValue: TGlyphShowMode);
    begin
      FButtonGlyph.ShowMode := AValue;
    end;
    
    procedure TCustomBitBtn.SetImageIndex(const aImageIndex: TImageIndex);
    begin
      FButtonGlyph.ExternalImageIndex := aImageIndex;
    end;
    
    procedure TCustomBitBtn.SetImages(const aImages: TCustomImageList);
    begin
      if FButtonGlyph.ExternalImages <> nil then
      begin
        FButtonGlyph.ExternalImages.UnRegisterChanges(FImageChangeLink);
        FButtonGlyph.ExternalImages.RemoveFreeNotification(Self);
      end;
      FButtonGlyph.ExternalImages := aImages;
      if FButtonGlyph.ExternalImages <> nil then
      begin
        FButtonGlyph.ExternalImages.FreeNotification(Self);
        FButtonGlyph.ExternalImages.RegisterChanges(FImageChangeLink);
      end;
      InvalidatePreferredSize;
      AdjustSize;
    end;
    
    procedure TCustomBitBtn.SetImageWidth(const aImageWidth: Integer);
    begin
      FButtonGlyph.ExternalImageWidth := aImageWidth;
      InvalidatePreferredSize;
      AdjustSize;
    end;
    
    procedure TCustomBitBtn.GlyphChanged(Sender: TObject);
    begin
      if HandleAllocated then
        TWSBitBtnClass(WidgetSetClass).SetGlyph(Self, FButtonGlyph);
      InvalidatePreferredSize;
      AdjustSize;
    end;
    
    procedure TCustomBitBtn.ImageListChange(Sender: TObject);
    begin
      if Sender = Images then
        GlyphChanged(Sender);
    end;
    
    procedure TCustomBitBtn.ActionChange(Sender: TObject; CheckDefaults: Boolean);
    begin
      inherited ActionChange(Sender,CheckDefaults);
      if Sender is TCustomAction then
      begin
        with TCustomAction(Sender) do
        begin
          if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
            (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
            ActionList.Images.GetBitmap(ImageIndex, Glyph);
        end;
      end;
    end;
    
    procedure TCustomBitBtn.SetKind(AValue: TBitBtnKind);
    begin
      if FKind = AValue then Exit;
      FKind := AValue;
      if (FKind <> bkCustom) and not (csLoading in ComponentState) then
        RealizeKind(True);
      if not (csLoading in ComponentState) then
        DefaultCaption := FKind <> bkCustom;
    end;
    
    procedure TCustomBitBtn.SetLayout(AValue: TButtonLayout);
    begin
      if FLayout = AValue then Exit;
      FLayout := AValue;
      if HandleAllocated then
      begin
        TWSBitBtnClass(WidgetSetClass).SetLayout(Self, FLayout);
        InvalidatePreferredSize;
      end;
      AdjustSize;
    end;
    
    procedure TCustomBitBtn.SetMargin(const AValue: integer);
    begin
      if FMargin = AValue then Exit;
      FMargin := AValue;
      if HandleAllocated  then
        TWSBitBtnClass(WidgetSetClass).SetMargin(Self, FMargin);
      AdjustSize;
      if csDesigning in ComponentState then
        Invalidate;
    end;
    
    procedure TCustomBitBtn.SetNumGlyphs(AValue: Integer);
    begin
      if AValue < Low(TNumGlyphs) then AValue := Low(TNumGlyphs);
      if AValue > High(TNumGlyphs) then AValue := High(TNumGlyphs);
    
      if AValue <> FButtonGlyph.NumGlyphs then
      Begin
        FButtonGlyph.NumGlyphs := TNumGlyphs(AValue);
        Invalidate;
      end;
    end;
    
    procedure TCustomBitBtn.SetSpacing(AValue: Integer);
    begin
      if (FSpacing = AValue) or (AValue < -1) then Exit;
      FSpacing := AValue;
      if HandleAllocated then
        TWSBitBtnClass(WidgetSetClass).SetSpacing(Self, FSpacing);
      AdjustSize;
      if csDesigning in ComponentState then
        Invalidate;
    end;
    
    procedure TCustomBitBtn.RealizeKind(ForceDefaults: Boolean);
    var
      GlyphValid, Handled: Boolean;
      CustomGlyph: TGraphic;
      BitmapHandle, MaskHandle: HBitmap;
      idButton: LongInt;
    begin
      if (Kind <> bkCustom) then
      begin
        GlyphValid := False;
        
        // first let the user override
        if GetDefaultBitBtnGlyph <> nil then
        begin
          Handled := False;
          CustomGlyph := GetDefaultBitBtnGlyph(Kind, Handled);
          if Handled then
          begin
            Glyph.Assign(CustomGlyph);
            CustomGlyph.Free;
            GlyphValid := True;
          end;
        end;
    
        // then ask the widgetset
        if not GlyphValid then 
        begin
          if ThemeServices.GetStockImage(BitBtnImages[Kind], BitmapHandle, MaskHandle) then
          begin
            Glyph.Handle := BitmapHandle;
            Glyph.MaskHandle := MaskHandle;
            GlyphValid := True;
          end;
        end;
        
        if not GlyphValid then
        begin
          if ForceDefaults or (Images=nil) then
          begin
            idButton := BitBtnImages[Kind];
            if (idButton >= Low(BitBtnResNames)) and (idButton <= High(BitBtnResNames))
            and (BitBtnResNames[idButton] <> '') then
              FButtonGlyph.LCLGlyphName := BitBtnResNames[idButton]
            else
              ImageIndex := -1;
            GlyphValid := True;
          end;
        end;
      end;
    
      if ForceDefaults then
      begin
        Caption := GetCaptionOfKind(Kind);
        ModalResult := BitBtnModalResults[Kind];
        Default := Kind in [bkOk, bkYes];
        Cancel := Kind in [bkCancel, bkNo];
      end;
    end;
    
    { Return the caption associated with the akind value.
      This function replaces BitBtnCaption const because the localizing
      do not work with an const array }
    function TCustomBitBtn.GetCaptionOfKind(AKind: TBitBtnKind): String;
    begin
      Result := GetButtonCaption(BitBtnImages[Kind]);
      if Result = '?' then
        Result := '';
    end;
    
    class procedure TCustomBitBtn.WSRegisterClass;
    begin
      inherited WSRegisterClass;
      RegisterCustomBitBtn;
    end;
    
    procedure TCustomBitBtn.InitializeWnd;
    begin
      inherited InitializeWnd;
      TWSBitBtnClass(WidgetSetClass).SetGlyph(Self, FButtonGlyph);
      TWSBitBtnClass(WidgetSetClass).SetLayout(Self, FLayout);
      TWSBitBtnClass(WidgetSetClass).SetMargin(Self, FMargin);  
      TWSBitBtnClass(WidgetSetClass).SetSpacing(Self, FSpacing);  
    end;
    
    function TCustomBitBtn.IsCaptionStored: Boolean;
    begin
      Result := inherited IsCaptionStored and not DefaultCaption;
    end;
    
    procedure TCustomBitBtn.Loaded;
    begin
      inherited Loaded;
      if (Kind <> bkCustom) then
        RealizeKind(False);
      if (Kind <> bkCustom) and DefaultCaption and (Caption = '') then
      begin
        Caption := GetCaptionOfKind(Kind); // Will trigger TextChanged
        DefaultCaption := True;
      end;
    end;
    
    procedure TCustomBitBtn.TextChanged;
    begin
      inherited TextChanged;
      AdjustSize;
      DefaultCaption := False;
    end;
    
    class function TCustomBitBtn.GetControlClassDefaultSize: TSize;
    begin
      Result.CX := 75;
      Result.CY := 30;
    end;
    
    procedure TCustomBitBtn.CMAppShowBtnGlyphChanged(var Message: TLMessage);
    begin
      if GlyphShowMode = gsmApplication then
        FButtonGlyph.Refresh;
    end;
    
    // included by buttons.pp
    
    bitbtn.inc (11,125 bytes)
  • buttons.pp (23,593 bytes)
    { $Id: buttons.pp 58244 2018-06-13 13:59:07Z juha $}
    
    {
     /***************************************************************************
                                     buttons.pp
                                     ----------
                                 Component Library Code
    
    
                       Initial Revision : Sun Mar 28 23:15:32 CST 1999
                       Revised: Sat Jul 3 1999
    
     ***************************************************************************/
    
     *****************************************************************************
      This file is part of the Lazarus Component Library (LCL)
    
      See the file COPYING.modifiedLGPL.txt, included in this distribution,
      for details about the license.
     *****************************************************************************
    }
    
    unit Buttons;
    
    {$mode objfpc}{$H+}
    
    interface
    
    {$ifdef Trace}
    {$ASSERTIONS ON}
    {$endif}
    
    uses
      Types, Classes, SysUtils, Math,
      // LCL
      LCLType, LCLProc, LCLIntf, LCLStrConsts,
      GraphType, Graphics, ImgList, ActnList, Controls, StdCtrls, LMessages, Forms,
      Themes, Menus, LResources, ImageListCache,
      // LazUtils
      LazUtilities;
    
    type
      TButtonLayout =
      (
        blGlyphLeft,
        blGlyphRight,
        blGlyphTop,
        blGlyphBottom
      );
    
      TButtonState =
      (
        bsUp,       // button is up
        bsDisabled, // button disabled (grayed)
        bsDown,     // button is down
        bsExclusive,// button is the only down in his group
        bsHot       // button is under mouse
      );
    
      {
       TNumGlyphs holds the number of glyphs in an image.
       If we change this the code in SetNumGlyphs for @link(TCustomSpeedButton)
       needs to be changed
      }
      TNumGlyphs = 1..5;
    
      { TButtonGlyph }
      TGlyphTransparencyMode = (
        gtmGlyph,       // transparency is defined by the glyph itself (bitbtn)
        gtmOpaque,      // transparent = false is defined by the owner (speedbutton)
        gtmTransparent  // transparent = true
      );
    
      TButtonGlyph = class(TObject, IUnknown, IImageCacheListener)
      private
        FIsDesigning: Boolean;
        FShowMode: TGlyphShowMode;
        FImageIndexes: array[TButtonState] of Integer;
        FImages: TCustomImageList;
        FExternalImages: TCustomImageList;
        FExternalImageIndex: Integer;
        FExternalImageWidth: Integer;
        FLCLGlyphResourceName: string;
        FOriginal: TBitmap;
        FNumGlyphs: TNumGlyphs;
        FOnChange: TNotifyEvent;
        FImagesCache: TImageListCache;
        FTransparentMode: TGlyphTransparencyMode;         // set by our owner to indicate that the glyphbitmap should be transparent
        FLCLGlyphName: string;
        function GetHeight: Integer;
        function GetNumGlyphs: TNumGlyphs;
        function GetWidth: Integer;
        procedure SetExternalImageIndex(const AExternalImageIndex: Integer);
        procedure SetExternalImages(const AExternalImages: TCustomImageList);
        procedure SetExternalImageWidth(const AExternalImageWidth: Integer);
        procedure SetGlyph(Value: TBitmap);
        procedure SetNumGlyphs(Value: TNumGlyphs);
        procedure SetShowMode(const AValue: TGlyphShowMode);
        procedure ClearImages;
        procedure ClearLCLGlyph;
        procedure SetLCLGlyphName(const ALCLGlyphName: string);
      public
        // IUnknown
        function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
        function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
        function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
        // IImageCacheListener
        procedure CacheSetImageList(AImageList: TCustomImageList);
        procedure CacheSetImageIndex(AIndex, AImageIndex: Integer);
      protected
        function CanShow: Boolean;
        function CanShowGlyph: Boolean;
        procedure DoChange; virtual;
        procedure GlyphChanged(Sender: TObject);
        procedure SetTransparentMode(AValue: TGlyphTransparencyMode);
        
        property TransparentMode: TGlyphTransparencyMode read FTransparentMode;
      public
        constructor Create;
        destructor Destroy; override;
        procedure GetImageIndexAndEffect(State: TButtonState;
          APPI: Integer; const ACanvasScaleFactor: Double;
          out AImageResolution: TScaledImageListResolution;
          out AIndex: Integer; out AEffect: TGraphicsDrawEffect);
        function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
                      State: TButtonState; Transparent: Boolean;
                      BiDiFlags: Longint): TRect;
        function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
                      State: TButtonState; Transparent: Boolean;
                      BiDiFlags, PPI: Longint; const ScaleFactor: Double): TRect;
        procedure Refresh;
        property Glyph: TBitmap read FOriginal write SetGlyph;
        property IsDesigning: Boolean read FIsDesigning write FIsDesigning;
        property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs;
        property Images: TCustomImageList read FImages;
        property LCLGlyphName: string read FLCLGlyphName write SetLCLGlyphName;
        property ExternalImages: TCustomImageList read FExternalImages write SetExternalImages;
        property ExternalImageIndex: Integer read FExternalImageIndex write SetExternalImageIndex;
        property ExternalImageWidth: Integer read FExternalImageWidth write SetExternalImageWidth;
        property Width: Integer read GetWidth;
        property Height: Integer read GetHeight;
        property ShowMode: TGlyphShowMode read FShowMode write SetShowMode;
      public
        property OnChange: TNotifyEvent read FOnChange write FOnChange;
      end;
    
    
      { TCustomBitBtn }
    
      // when adding items here, also update TBitBtn.GetCaptionOfKind
      TBitBtnKind = (bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo,
                     bkClose, bkAbort, bkRetry, bkIgnore, bkAll,
                     bkNoToAll, bkYesToAll);
      TBitBtnKinds = set of TBitBtnKind;
    
      TCustomBitBtn = class(TCustomButton)
      private
        FDefaultCaption: Boolean;
        FKind: TBitBtnKind;
        FLayout: TButtonLayout;
        FMargin: integer;
        FSpacing: Integer;
        FImageChangeLink: TChangeLink;
        function GetGlyph: TBitmap;
        function GetGlyphShowMode: TGlyphShowMode;
        function GetNumGlyphs: Integer;
        procedure ImageListChange(Sender: TObject);
        function IsGlyphStored: Boolean;
        procedure SetGlyph(AValue: TBitmap);
        procedure SetGlyphShowMode(const AValue: TGlyphShowMode);
        procedure SetKind(AValue: TBitBtnKind);
        procedure SetLayout(AValue: TButtonLayout);
        procedure SetMargin(const AValue: integer);
        procedure SetNumGlyphs(AValue: Integer);
        procedure SetSpacing(AValue: Integer);
        procedure RealizeKind(ForceDefaults: Boolean);
        //Return the caption associated with the aKind value.
        function GetCaptionOfKind(AKind: TBitBtnKind): String;
        function GetImages: TCustomImageList;
        procedure SetImages(const aImages: TCustomImageList);
        function GetImageIndex: TImageIndex;
        procedure SetImageIndex(const aImageIndex: TImageIndex);
        function GetImageWidth: Integer;
        procedure SetImageWidth(const aImageWidth: Integer);
      protected
    
        FButtonGlyph: TButtonGlyph;
        class procedure WSRegisterClass; override;
        procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
        procedure GlyphChanged(Sender: TObject);
        procedure InitializeWnd; override;
        function IsCaptionStored: Boolean;
        procedure Loaded; override;
        procedure Notification(AComponent: TComponent;
          Operation: TOperation); override;
        procedure TextChanged; override;
        class function GetControlClassDefaultSize: TSize; override;
        procedure CMAppShowBtnGlyphChanged(var Message: TLMessage); message CM_APPSHOWBTNGLYPHCHANGED;
      public
        constructor Create(TheOwner: TComponent); override;
        destructor Destroy; override;
        procedure Click; override;
        procedure LoadGlyphFromResourceName(Instance: THandle; const AName: String);
        procedure LoadGlyphFromLazarusResource(const AName: String);
        procedure LoadGlyphFromStock(idButton: Integer);
        function CanShowGlyph(const AWithShowMode: Boolean = False): Boolean;
      public
      
        //2020-02-08 zhangch2010
        NewBitmap: HBITMAP; // Handle of the new bitmap
    	
        property Caption stored IsCaptionStored;
        property DefaultCaption: Boolean read FDefaultCaption write FDefaultCaption default False;
        property Glyph: TBitmap read GetGlyph write SetGlyph stored IsGlyphStored;
        property NumGlyphs: Integer read GetNumGlyphs write SetNumGlyphs default 1;
        property Images: TCustomImageList read GetImages write SetImages;
        property ImageIndex: TImageIndex read GetImageIndex write SetImageIndex default -1;
        property ImageWidth: Integer read GetImageWidth write SetImageWidth default 0;
        property Kind: TBitBtnKind read FKind write SetKind default bkCustom;
        property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
        property Margin: integer read FMargin write SetMargin default -1;
        property Spacing: Integer read FSpacing write SetSpacing default 4;
        property GlyphShowMode: TGlyphShowMode read GetGlyphShowMode write SetGlyphShowMode default gsmApplication;
      end;
    
      { TBitBtn }
      { To set custom bitbtn glyphs for the whole application, see below for
        GetDefaultBitBtnGlyph }
    
      TBitBtn = class(TCustomBitBtn)
      published
        property Action;
        property Align;
        property Anchors;
        property AutoSize;
        property BidiMode;
        property BorderSpacing;
        property Cancel;
        property Caption;
        property Color;
        property Constraints;
        property Default;
        property DefaultCaption;
        property Enabled;
        property Font;
        property Glyph;
        property GlyphShowMode;
        property Kind;
        property Layout;
        property Margin;
        property ModalResult;
        property NumGlyphs;
        property Images;
        property ImageIndex;
        property ImageWidth;
        property OnChangeBounds;
        property OnClick;
        property OnContextPopup;
        property OnDragDrop;
        property OnDragOver;
        property OnEndDrag;
        property OnEnter;
        property OnExit;
        property OnKeyDown;
        property OnKeyPress;
        property OnKeyUp;
        property OnMouseDown;
        property OnMouseEnter;
        property OnMouseLeave;
        property OnMouseMove;
        property OnMouseUp;
        property OnMouseWheel;
        property OnMouseWheelDown;
        property OnMouseWheelUp;
        property OnResize;
        property OnStartDrag;
        property OnUTF8KeyPress;
        property ParentBidiMode;
        property ParentFont;
        property ParentShowHint;
        property PopupMenu;
        property ShowHint;
        property Spacing;
        property TabOrder;
        property TabStop;
        property Visible;
      end;
    
    
      { TSpeedButtonActionLink }
    
      TSpeedButtonActionLink = class(TControlActionLink)
      protected
        procedure AssignClient(AClient: TObject); override;
        procedure SetGroupIndex(Value: Integer); override;
        procedure SetChecked(Value: Boolean); override;
      public
        function IsCheckedLinked: Boolean; override;
        function IsGroupIndexLinked: Boolean; override;
      end;
    
      { TCustomSpeedButton }
    
      TCustomSpeedButton = class(TGraphicControl)
      private
        FGlyph: TButtonGlyph;
        FGroupIndex: Integer;
        FImageChangeLink: TChangeLink;
        FLastDrawDetails: TThemedElementDetails;
        FLayout: TButtonLayout;
        FMargin: integer;
        FSpacing: integer;
        FShortcut: TShortCut;
        FShowAccelChar: boolean;
        FShowCaption: boolean;
        FAllowAllUp: Boolean;
        FDown: Boolean;
        FDownLoaded : Boolean;// value of Down set during loading
        FDragging: Boolean;
        FFlat: Boolean;
        FMouseInControl: Boolean;
        function GetGlyph: TBitmap;
        procedure ImageListChange(Sender: TObject);
        function IsGlyphStored: Boolean;
        procedure SetShowCaption(const AValue: boolean);
        procedure UpdateExclusive;
        function  GetTransparent: Boolean;
        procedure SetAllowAllUp(Value: Boolean);
        procedure SetGlyph(Value: TBitmap);
        procedure SetLayout(const Value: TButtonLayout);
        procedure SetShowAccelChar(Value: boolean);
        procedure SetTransparent(const AValue: boolean);
        procedure CMButtonPressed(var Message: TLMessage); message CM_BUTTONPRESSED;
        procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED;
      private
        procedure DoMouseUp(var Message: TLMMouse; Button: TMouseButton);
        procedure WMLButtonDown(Var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
        procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
        procedure WMLButtonDBLCLK(Var Message: TLMLButtonDblClk); message LM_LBUTTONDBLCLK;
        function GetImages: TCustomImageList;
        procedure SetImages(const aImages: TCustomImageList);
        function GetImageIndex: TImageIndex;
        procedure SetImageIndex(const aImageIndex: TImageIndex);
        function GetImageWidth: Integer;
        procedure SetImageWidth(const aImageWidth: Integer);
      protected
        FState: TButtonState;
        class procedure WSRegisterClass; override;
        function ButtonGlyph: TButtonGlyph;
        function GetNumGlyphs: Integer;
        procedure GlyphChanged(Sender: TObject); virtual;
        function  DialogChar(var Message: TLMKey): boolean; override;
        procedure CalculatePreferredSize(var PreferredWidth,
          PreferredHeight: integer; WithThemeSpace: Boolean); override;
        procedure MeasureDraw(Draw: boolean; PaintRect: TRect;
                              out PreferredWidth, PreferredHeight: integer);
        procedure MouseEnter; override;
        procedure MouseLeave; override;
        procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
          X, Y: Integer); override;
        procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
        procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
          X, Y: Integer); override;
        procedure Notification(AComponent: TComponent;
          Operation: TOperation); override;
        procedure Paint; override;
        procedure PaintBackground(var PaintRect: TRect); virtual;
        procedure SetDown(Value: Boolean);
        procedure SetGroupIndex(const Value: Integer);
        procedure SetFlat(const Value: Boolean);
        procedure SetMargin(const Value: integer);
        procedure SetNumGlyphs(Value: integer);
        procedure SetSpacing(const Value: integer);
        procedure RealSetText(const Value: TCaption); override;
        procedure UpdateState(InvalidateOnChange: boolean); virtual;
        function GetDrawDetails: TThemedElementDetails; virtual;
        property MouseInControl: Boolean read FMouseInControl;
        procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
        function GetActionLinkClass: TControlActionLinkClass; override;
        class function GetControlClassDefaultSize: TSize; override;
        procedure Loaded; override;
      protected
        function GetGlyphSize(Drawing: boolean; PaintRect: TRect): TSize; virtual;
        function GetTextSize(Drawing: boolean; PaintRect: TRect): TSize; virtual;
        function DrawGlyph(ACanvas: TCanvas; const AClient: TRect; const AOffset: TPoint;
          AState: TButtonState; ATransparent: Boolean; BiDiFlags: Longint): TRect; virtual;
      public
        constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;
        function FindDownButton: TCustomSpeedButton;
        procedure Click; override; // make Click public
        procedure LoadGlyphFromResourceName(Instance: THandle; const AName: String);
        procedure LoadGlyphFromLazarusResource(const AName: String);
      public
        property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default false;
        property Color default clBtnFace;
        property Down: Boolean read FDown write SetDown default false;
        property Flat: Boolean read FFlat write SetFlat default false;
        property Glyph: TBitmap read GetGlyph write SetGlyph stored IsGlyphStored;
        property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
        property Images: TCustomImageList read GetImages write SetImages;
        property ImageIndex: TImageIndex read GetImageIndex write SetImageIndex default -1;
        property ImageWidth: Integer read GetImageWidth write SetImageWidth default 0;
        property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
        property Margin: integer read FMargin write SetMargin default -1;
        property NumGlyphs: Integer read GetNumGlyphs write SetNumGlyphs default 1;
        property ShowAccelChar: boolean read FShowAccelChar write SetShowAccelChar default true;
        property ShowCaption: boolean read FShowCaption write SetShowCaption default true;
        property Spacing: integer read FSpacing write SetSpacing default 4;
        property Transparent: Boolean read GetTransparent write SetTransparent default true;
      end;
    
    
      { TSpeedButton }
    
      TSpeedButton = class(TCustomSpeedButton)
      published
        property Action;
        property Align;
        property AllowAllUp;
        property Anchors;
        property AutoSize;
        property BidiMode;
        property BorderSpacing;
        property Constraints;
        property Caption;
        property Color;
        property Down;
        property Enabled;
        property Flat;
        property Font;
        property Glyph;
        property GroupIndex;
        property Images;
        property ImageIndex;
        property ImageWidth;
        property Layout;
        property Margin;
        property NumGlyphs;
        property Spacing;
        property Transparent;
        property Visible;
        property OnClick;
        property OnDblClick;
        property OnMouseDown;
        property OnMouseEnter;
        property OnMouseLeave;
        property OnMouseMove;
        property OnMouseUp;
        property OnMouseWheel;
        property OnMouseWheelDown;
        property OnMouseWheelUp;
        property OnPaint;
        property OnResize;
        property OnChangeBounds;
        property ShowCaption;
        property ShowHint;
        property ParentBidiMode;
        property ParentFont;
        property ParentShowHint;
        property PopupMenu;
      end;
    
      { To override the default TBitBtn glyphs set GetDefaultBitBtnGlyph below.
        Example:
    
        function GetBitBtnGlyph(Kind: TBitBtnKind): TBitmap;
        begin
          if Kind in [bkOK, bkCancel] then begin
            Result:=TBitmap.Create;
            case Kind of
              bkOk:      Result.Assign(MyOkGlyph);
              bkCancel:  Result.Assign(MyCancelGlyph);
            end;
          end else
            Result:=nil;
        end;
        }
    type
      TGetDefaultBitBtnGlyph = function(Kind: TBitBtnKind; var Handled: Boolean): TBitmap;
    var
      GetDefaultBitBtnGlyph: TGetDefaultBitBtnGlyph = nil;
    
    function GetLCLDefaultBtnGlyph(Kind: TBitBtnKind): TGraphic;
    procedure LoadGlyphFromResourceName(AGlyph: TButtonGlyph; Instance: THandle; const AName: String);
    procedure LoadGlyphFromLazarusResource(AGlyph: TButtonGlyph; const AName: String);
    procedure LoadGlyphFromStock(AGlyph: TButtonGlyph; idButton: Integer);
    
    // helper functions (search LCLType for idButton)
    function GetButtonCaption(idButton: Integer): String;
    function GetDefaultButtonIcon(idButton: Integer; ScalePercent: Integer = 100): TCustomBitmap;
    function GetButtonIcon(idButton: Integer): TCustomBitmap;
    function BidiAdjustButtonLayout(IsRightToLeft: Boolean; Layout: TButtonLayout): TButtonLayout;
    
    function dbgs(Kind: TBitBtnKind): string; overload;
    
    procedure Register;
    
    const
      BitBtnModalResults: array[TBitBtnKind] of TModalResult = (
        0, mrOK, mrCancel, 0, mrYes, mrNo,
        mrClose, mrAbort, mrRetry, mrIgnore, mrAll,
        mrNoToAll, mrYesToAll);
    
      BitBtnImages: array[TBitBtnKind] of Longint = (
        idButtonBase, idButtonOk, idButtonCancel, idButtonHelp, idButtonYes,
        idButtonNo, idButtonClose, idButtonAbort, idButtonRetry, idButtonIgnore,
        idButtonAll, idButtonNoToAll, idButtonYesToAll);
    
      BitBtnResNames: array[idButtonOk..idButtonNoToAll] of String =
      (
    {idButtonOk      } 'btn_ok',
    {idButtonCancel  } 'btn_cancel',
    {idButtonHelp    } 'btn_help',
    {idButtonYes     } 'btn_yes',
    {idButtonNo      } 'btn_no',
    {idButtonClose   } 'btn_close',
    {idButtonAbort   } 'btn_abort',
    {idButtonRetry   } 'btn_retry',
    {idButtonIgnore  } 'btn_ignore',
    {idButtonAll     } 'btn_all',
    {idButtonYesToAll} 'btn_all',
    {idButtonNoToAll } 'btn_no'
      );
    
    implementation
    
    {$R btn_icons.res}
    
    uses
      WSButtons;
    
    function GetLCLDefaultBtnGlyph(Kind: TBitBtnKind): TGraphic;
    begin
      Result := GetDefaultButtonIcon(BitBtnImages[Kind]);
    end;
    
    function GetDefaultButtonIcon(idButton: Integer;
      ScalePercent: Integer): TCustomBitmap;
    var
      ResName: string;
    begin
      Result := nil;
      if (idButton < Low(BitBtnResNames)) or (idButton > High(BitBtnResNames)) then
        Exit;
      if BitBtnResNames[idButton] = '' then
        Exit;
      Result := GetDefaultGlyph(BitBtnResNames[idButton], ScalePercent);
    end;
    
    procedure LoadGlyphFromResourceName(AGlyph: TButtonGlyph; Instance: THandle; const AName: String);
    var
      C: TCustomBitmap;
    begin
      if AName = '' then
        C := nil
      else
        C := CreateBitmapFromResourceName(Instance, AName);
    
      try
        AGlyph.Glyph.Assign(C);
      finally
        C.Free;
      end;
    end;
    
    procedure LoadGlyphFromLazarusResource(AGlyph: TButtonGlyph; const AName: String);
    var
      C: TCustomBitmap;
    begin
      if AName = '' then
        C := nil
      else
        C := CreateBitmapFromLazarusResource(AName);
    
      try
        AGlyph.Glyph.Assign(C);
      finally
        C.Free;
      end;
    end;
    
    procedure LoadGlyphFromStock(AGlyph: TButtonGlyph; idButton: Integer);
    var
      C: TCustomBitmap;
    begin
      C := GetButtonIcon(idButton);
      try
        AGlyph.Glyph.Assign(C);
      finally
        C.Free;
      end;
    end;
    
    function GetButtonCaption(idButton: Integer): String;
    begin
      case idButton of
        idButtonOk       : Result := rsmbOK;
        idButtonCancel   : Result := rsmbCancel;
        idButtonHelp     : Result := rsmbHelp;
        idButtonYes      : Result := rsmbYes;
        idButtonNo       : Result := rsmbNo;
        idButtonClose    : Result := rsmbClose;
        idButtonAbort    : Result := rsmbAbort;
        idButtonRetry    : Result := rsmbRetry;
        idButtonIgnore   : Result := rsmbIgnore;
        idButtonAll      : Result := rsmbAll;
        idButtonYesToAll : Result := rsmbYesToAll;
        idButtonNoToAll  : Result := rsmbNoToAll;
        idButtonOpen     : Result := rsmbOpen;
        idButtonSave     : Result := rsmbSave;
        idButtonShield   : Result := rsmbUnlock;
      else
        Result := '?';
      end;
    end;
    
    function GetButtonIcon(idButton: Integer): TCustomBitmap;
    var
      BitmapHandle, MaskHandle: HBitmap;
    begin
      if ThemeServices.GetStockImage(idButton, BitmapHandle, MaskHandle) then
      begin
        Result := TBitmap.Create;
        Result.Handle := BitmapHandle;
        if MaskHandle <> 0 then
          Result.MaskHandle := MaskHandle;
      end
      else
        Result := GetDefaultButtonIcon(idButton);
    end;
    
    const
      BtnBidiLayout: array[Boolean, TButtonLayout] of TButtonLayout =
      (
        (
          blGlyphLeft,
          blGlyphRight,
          blGlyphTop,
          blGlyphBottom
        ),
        (
          blGlyphRight,
          blGlyphLeft,
          blGlyphTop,
          blGlyphBottom
        )
      );
    
    function BidiAdjustButtonLayout(IsRightToLeft: Boolean; Layout: TButtonLayout): TButtonLayout;
    begin
      Result := BtnBidiLayout[IsRightToLeft, Layout];
    end;
    
    function dbgs(Kind: TBitBtnKind): string;
    begin
      Result:='';
      writestr(Result,Kind);
    end;
    
    procedure Register;
    begin
      RegisterComponents('Additional',[TBitBtn,TSpeedButton]);
    end;
    
    {$I bitbtn.inc}
    {$I buttonglyph.inc}
    {$I speedbutton.inc}
    
    end.
    
    buttons.pp (23,593 bytes)
  • win32wsbuttons.pp (25,136 bytes)
    { $Id: win32wsbuttons.pp 59282 2018-10-09 23:07:37Z maxim $}
    {
     *****************************************************************************
     *                             Win32WSButtons.pp                             *
     *                             -----------------                             *
     *                                                                           *
     *                                                                           *
     *****************************************************************************
    
     *****************************************************************************
      This file is part of the Lazarus Component Library (LCL)
    
      See the file COPYING.modifiedLGPL.txt, included in this distribution,
      for details about the license.
     *****************************************************************************
    }
    unit Win32WSButtons;
    
    {$mode objfpc}{$H+}
    {$I win32defines.inc}
    
    interface
    
    uses
    ////////////////////////////////////////////////////
    // I M P O R T A N T
    ////////////////////////////////////////////////////
    // To get as little as posible circles,
    // uncomment only when needed for registration
    ////////////////////////////////////////////////////
      Windows, CommCtrl, Classes, Buttons, Graphics, GraphType, Controls,
      LCLType, LCLMessageGlue, LMessages, LazUTF8, Themes, ImgList,
    ////////////////////////////////////////////////////
      WSProc, WSButtons, Win32WSControls, Win32WSImgList,
      UxTheme, Win32Themes;
    
    type
    
      { TWin32WSBitBtn }
    
      TWin32WSBitBtn = class(TWSBitBtn)
      published
        class function CreateHandle(const AWinControl: TWinControl;
              const AParams: TCreateParams): HWND; override;
        class procedure GetPreferredSize(const AWinControl: TWinControl;
              var PreferredWidth, PreferredHeight: integer;
              WithThemeSpace: Boolean); override;
        class procedure SetBounds(const AWinControl: TWinControl;
              const ALeft, ATop, AWidth, AHeight: integer); override;
        class procedure SetBiDiMode(const AWinControl: TWinControl; UseRightToLeftAlign, UseRightToLeftReading, UseRightToLeftScrollBar : Boolean); override;
        class procedure SetColor(const AWinControl: TWinControl); override;
        class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override;
        class procedure SetGlyph(const ABitBtn: TCustomBitBtn; const AValue: TButtonGlyph); override;
        class procedure SetLayout(const ABitBtn: TCustomBitBtn; const AValue: TButtonLayout); override;
        class procedure SetMargin(const ABitBtn: TCustomBitBtn; const AValue: Integer); override;
        class procedure SetSpacing(const ABitBtn: TCustomBitBtn; const AValue: Integer); override;
        class procedure SetText(const AWinControl: TWinControl; const AText: string); override;
      end;
    
      { TWin32WSSpeedButton }
    
      TWin32WSSpeedButton = class(TWSSpeedButton)
      published
      end;
    
    procedure DrawBitBtnImage(BitBtn: TCustomBitBtn; const ButtonCaption: string);
    
    implementation
    
    uses
      Win32Int, Win32Proc;
    
    type
      TBitBtnAceess = class(TCustomBitBtn)
      end;
    
    { TWin32WSBitBtn }
    
    const
      { - you do need to destroy the imagelist yourself.
        - you'll need 5 images to support all themed xp button states...
    
        Image 0 = NORMAL
        Image 1 = HOT
        Image 2 = PRESSED
        Image 3 = DISABLED
        Image 4 = DEFAULTED
        Image 5 = STYLUSHOT - for tablet computers
      }
    
      XPBitBtn_ImageIndexToState: array[1..6] of TButtonState =
        (bsUp, bsHot, bsDown, bsDisabled, bsUp, bsHot);
      BitBtnEnabledToButtonState: array[boolean] of TButtonState =
        (bsDisabled, bsUp);
    
    function Create32BitHBitmap(ADC: HDC; AWidth, AHeight: Integer; out BitsPtr: Pointer): HBitmap;
    var
      Info: Windows.TBitmapInfo;
    begin
      FillChar(Info, SizeOf(Info), 0);
      Info.bmiHeader.biSize := SizeOf(Info.bmiHeader);
      Info.bmiHeader.biWidth := AWidth;
      Info.bmiHeader.biHeight := -AHeight; // top down
      Info.bmiHeader.biPlanes := 1;
      Info.bmiHeader.biBitCount := 32;
      Info.bmiHeader.biCompression := BI_RGB;
      BitsPtr := nil;
      Result := Windows.CreateDIBSection(ADC, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS, BitsPtr, 0, 0);
    end;
    
    {------------------------------------------------------------------------------
      Method: DrawBitBtnImage
      Params:  BitBtn: The TCustomBitBtn to update the image of
               ButtonCaption: new button caption
      Returns: Nothing
    
      Updates the button image combining the glyph and caption
     ------------------------------------------------------------------------------}
    procedure DrawBitBtnImage(BitBtn: TCustomBitBtn; const ButtonCaption: string);
    var
      BitBtnLayout: TButtonLayout; // Layout of button and glyph
      BitBtnHandle: HWND; // Handle to bitbtn window
      BitBtnDC: HDC; // Handle to DC of bitbtn window
      OldFontHandle: HFONT; // Handle of previous font in hdcNewBitmap
      hdcNewBitmap: HDC; // Device context of the new Bitmap
      TextSize: Windows.SIZE; // For computing the length of button caption in pixels
      OldBitmap: HBITMAP; // Handle to the old selected bitmap
      NewBitmap: HBITMAP; // Handle of the new bitmap
      XDestBitmap, YDestBitmap: integer; // X,Y coordinate of destination rectangle for bitmap
      XDestText, YDestText: integer; // X,Y coordinates of destination rectangle for caption
      newWidth, newHeight: integer; // dimensions of new combined bitmap
      srcWidth, srcHeight: integer; // width of glyph to use, bitmap may have multiple glyphs
      BitmapRect: Windows.RECT;
      ButtonImageList: BUTTON_IMAGELIST;
      I: integer;
      ButtonCaptionW: widestring;
      AIndex: Integer;
      AImageRes: TScaledImageListResolution;
      AEffect: TGraphicsDrawEffect;
    
      procedure DrawBitmap(AState: TButtonState; UseThemes, AlphaDraw: Boolean);
      const
        DSS_HIDEPREFIX = $0200;
        StateToDetail: array[TButtonState] of TThemedButton =
        (
         { bsUp        } tbPushButtonNormal,
         { bsDisabled  } tbPushButtonDisabled,
         { bsDown      } tbPushButtonPressed,
         { bsExclusive } tbPushButtonPressed,
         { bsHot       } tbPushButtonHot
        );
      var
        TextFlags: DWord; // flags for caption (enabled or disabled)
        glyphWidth, glyphHeight: integer;
        OldBitmapHandle: HBITMAP; // Handle of the provious bitmap in hdcNewBitmap
        OldTextAlign: Integer;
        TmpDC: HDC;
        PaintBuffer: HPAINTBUFFER;
        Options: DTTOpts;
        Details: TThemedElementDetails;
        ShowAccel: Boolean;
        Color: TColor;
        PaintParams: TBP_PaintParams;
      begin
        glyphWidth := srcWidth;
        glyphHeight := srcHeight;
    
        if WindowsVersion >= wv2000 then
          ShowAccel := (SendMessage(BitBtnHandle, WM_QUERYUISTATE, 0, 0) and UISF_HIDEACCEL) = 0
        else
          ShowAccel := True;
    
        OldBitmapHandle := SelectObject(hdcNewBitmap, NewBitmap);
        if UseThemes and AlphaDraw then
        begin
          FillChar(PaintParams, SizeOf(PaintParams), 0);
          PaintParams.cbSize := SizeOf(PaintParams);
          PaintParams.dwFlags := BPPF_ERASE;
          PaintBuffer := BeginBufferedPaint(hdcNewBitmap, @BitmapRect, BPBF_COMPOSITED, @PaintParams, TmpDC);
        end
        else
        begin
          TmpDC := hdcNewBitmap;
          PaintBuffer := 0;
        end;
        OldFontHandle := SelectObject(TmpDC, BitBtn.Font.Reference.Handle);
        OldTextAlign := GetTextAlign(TmpDC);
    
        // clear background:
        // for alpha bitmap clear it with $00000000 else make it solid color for
        // further masking
        if PaintBuffer = 0 then
        begin
          Windows.FillRect(TmpDC, BitmapRect, GetSysColorBrush(COLOR_BTNFACE));
          Color := BitBtn.Font.Color;
          if Color = clDefault then
            Color := BitBtn.GetDefaultColor(dctFont);
          SetTextColor(TmpDC, ColorToRGB(Color));
        end;
    
        if AState <> bsDisabled then
        begin
          if (srcWidth <> 0) and (srcHeight <> 0) then
          begin
            TBitBtnAceess(BitBtn).FButtonGlyph.GetImageIndexAndEffect(AState, BitBtn.Font.PixelsPerInch, 1,
              AImageRes, AIndex, AEffect);
            TWin32WSCustomImageListResolution.DrawToDC(
              AImageRes.Resolution,
              AIndex, TmpDC, Rect(XDestBitmap, YDestBitmap, glyphWidth, glyphHeight),
              AImageRes.Resolution.ImageList.BkColor,
              AImageRes.Resolution.ImageList.BlendColor, AEffect,
              AImageRes.Resolution.ImageList.DrawingStyle,
              AImageRes.Resolution.ImageList.ImageType);
          end;
        end else
        begin
          // when not themed, windows wants a white background picture for disabled button image
          if not UseThemes then
            FillRect(TmpDC, BitmapRect, GetStockObject(WHITE_BRUSH));
    
          if (srcWidth <> 0) and (srcHeight <> 0) then
          begin
            TBitBtnAceess(BitBtn).FButtonGlyph.GetImageIndexAndEffect(AState, BitBtn.Font.PixelsPerInch, 1,
              AImageRes, AIndex, AEffect);
            if UseThemes and not AlphaDraw then
            begin
              // non-themed winapi wants white/other as background/picture-disabled colors
              // themed winapi draws bitmap-as, with transparency defined by bitbtn.brush color
              SetBkColor(TmpDC, GetSysColor(COLOR_BTNFACE));
              SetTextColor(TmpDC, GetSysColor(COLOR_BTNSHADOW));
            end
            else
            if (AEffect = gdeDisabled) and not AlphaDraw then
              AEffect := gde1Bit;
    
            TWin32WSCustomImageListResolution.DrawToDC(
              AImageRes.Resolution,
              AIndex, TmpDC, Rect(XDestBitmap, YDestBitmap, glyphWidth, glyphHeight),
              AImageRes.Resolution.ImageList.BkColor,
              AImageRes.Resolution.ImageList.BlendColor, AEffect,
              AImageRes.Resolution.ImageList.DrawingStyle,
              AImageRes.Resolution.ImageList.ImageType);
          end;
        end;
        if PaintBuffer = 0 then
        begin
          TextFlags := DST_PREFIXTEXT;
    
          if (AState = bsDisabled) then
            TextFlags := TextFlags or DSS_DISABLED;
    
          if not ShowAccel then
            TextFlags := TextFlags or DSS_HIDEPREFIX;
    
          SetBkMode(TmpDC, TRANSPARENT);
          if BitBtn.UseRightToLeftReading then
            SetTextAlign(TmpDC, OldTextAlign or TA_RTLREADING);
          ButtonCaptionW := UTF8ToUTF16(ButtonCaption);
          DrawStateW(TmpDC, 0, nil, LPARAM(ButtonCaptionW), 0, XDestText, YDestText, 0, 0, TextFlags);
        end
        else
        begin
          Details := ThemeServices.GetElementDetails(StateToDetail[AState]);
          FillChar(Options, SizeOf(Options), 0);
          Options.dwSize := SizeOf(Options);
          Options.dwFlags := DTT_COMPOSITED;
          TextFlags := DT_SINGLELINE;
          if not ShowAccel then
            TextFlags := TextFlags or DT_HIDEPREFIX;
          if AState <> bsDisabled then
          begin
            // change color to requested or it will be black
            Color := BitBtn.Font.Color;
            if Color = clDefault then
              Color := BitBtn.GetDefaultColor(dctFont);
            Options.crText := ThemeServices.ColorToRGB(Color, @Details);
            Options.dwFlags := Options.dwFlags or DTT_TEXTCOLOR;
          end;
          TWin32ThemeServices(ThemeServices).DrawTextEx(TmpDC, Details, ButtonCaption,
            Rect(XDestText, YDestText, XDestText + TextSize.cx, YDestText + TextSize.cy),
            TextFlags, @Options);
        end;
        SetTextAlign(TmpDC, OldTextAlign);
        SelectObject(TmpDC, OldFontHandle);
        if PaintBuffer <> 0 then
          EndBufferedPaint(PaintBuffer, True);
        NewBitmap := SelectObject(hdcNewBitmap, OldBitmapHandle);
      end;
    
    var
      RGBA: PRGBAQuad;
      AlphaDraw: Boolean;
      ASpacing: Integer;
      lMargin: Integer;
    begin
      // gather info about bitbtn
      BitBtnHandle := BitBtn.Handle;
      ASpacing := BitBtn.Spacing;
      if BitBtn.Margin = -1 then lMargin := 0 else lMargin := BitBtn.Margin;
    
      if BitBtn.CanShowGlyph(True) then
      begin
        TBitBtnAceess(BitBtn).FButtonGlyph.GetImageIndexAndEffect(Low(TButtonState), BitBtn.Font.PixelsPerInch, 1,
          AImageRes, AIndex, AEffect);
        srcWidth := AImageRes.Width;
        srcHeight := AImageRes.Height;
      end else
      begin
        srcWidth := 0;
        srcHeight := 0;
      end;
      {set spacing to LCL's default if bitbtn does not have glyph.issue #23255}
      if (srcWidth = 0) or (srcHeight = 0) then
        ASpacing := 0;
      newWidth := 0;
      newHeight := 0;
      BitBtnLayout := BidiAdjustButtonLayout(BitBtn.UseRightToLeftReading, BitBtn.Layout);
      BitBtnDC := GetDC(BitBtnHandle);
      hdcNewBitmap := CreateCompatibleDC(BitBtnDC);
      MeasureText(BitBtn, ButtonCaption, TextSize.cx, TextSize.cy);
      // calculate size of new bitmap
      case BitBtnLayout of
        blGlyphLeft, blGlyphRight:
        begin
          if ASpacing = -1 then
            newWidth := BitBtn.Width
          else
            newWidth := TextSize.cx + srcWidth + ASpacing + lMargin;
          newHeight := TextSize.cy;
          if newHeight < srcHeight then
            newHeight := srcHeight;
          YDestBitmap := (newHeight - srcHeight) div 2;
          YDestText := (newHeight - TextSize.cy) div 2;
          case BitBtnLayout of
            blGlyphLeft:
            begin
              XDestBitmap := lMargin;
              XDestText := srcWidth;
              if ASpacing = -1 then begin
                if BitBtn.Margin = -1 then begin
                  XDestBitmap := (BitBtn.Width - (srcWidth + TextSize.cx)) div 3;
                  XDestText := 2*XDestBitmap + srcWidth;
                end else
                  inc(XDestText, (newWidth - srcWidth - TextSize.cx + lMargin) div 2);
              end else
                inc(XDestText, ASpacing + lMargin);
            end;
            blGlyphRight:
            begin
              XDestBitmap := newWidth - srcWidth - lMargin;
              XDestText := XDestBitmap - TextSize.cx;
              if ASpacing = -1 then begin
                if BitBtn.Margin = -1 then begin
                  XDestText := (BitBtn.Width - (srcWidth + TextSize.cx)) div 3;
                  XDestBitmap := 2 * XDestText + TextSize.cx;
                end else
                  dec(XDestText, (newWidth - srcWidth - TextSize.cx - lMargin) div 2)
              end else
                dec(XDestText, ASpacing);
            end;
          end;
        end;
        blGlyphTop, blGlyphBottom:
        begin
          newWidth := TextSize.cx;
          if newWidth < srcWidth then
            newWidth := srcWidth;
          if ASpacing = -1 then
            newHeight := BitBtn.Height
          else
            newHeight := TextSize.cy + srcHeight + ASpacing + lMargin;
          XDestBitmap := (newWidth - srcWidth) shr 1;
          XDestText := (newWidth - TextSize.cx) shr 1;
          case BitBtnLayout of
            blGlyphTop:
            begin
              YDestBitmap := lMargin;
              YDestText := srcHeight;
              if ASpacing = -1 then begin
                if BitBtn.Margin = -1 then begin
                  YDestBitmap := (BitBtn.Height - (srcHeight + TextSize.cy)) div 3;
                  YDestText := 2*YDestBitmap + srcHeight;
                end else
                  inc(YDestText, (newHeight - srcHeight - TextSize.cy + lMargin) div 2)
              end else
                inc(YDestText, ASpacing + lMargin);
            end;
            blGlyphBottom:
            begin
              YDestBitmap := newHeight - srcHeight - lMargin;
              YDestText := YDestBitmap - TextSize.cy;
              if ASpacing = -1 then begin
                if BitBtn.Margin = -1 then begin
                  YDestText := (BitBtn.Height - (srcHeight + TextSize.cy)) div 3;
                  YDestBitmap := 2 * YDestText + TextSize.cy;
                end else
                  dec(YDestText, (newHeight - srcHeight - TextSize.cy - lMargin) div 2)
              end else
                dec(YDestText, ASpacing);
            end;
          end;
        end;
      end;
    
      // create new
      BitmapRect.left := 0;
      BitmapRect.top := 0;
      BitmapRect.right := newWidth;
      BitmapRect.bottom := newHeight;
    
      AlphaDraw := ThemeServices.ThemesEnabled and (BeginBufferedPaint <> nil);
    
      if (newWidth = 0) or (newHeight = 0) then
        NewBitmap := 0
      else
      if AlphaDraw then
        NewBitmap := Create32BitHBitmap(BitBtnDC, newWidth, newHeight, RGBA)
      else
        NewBitmap := CreateCompatibleBitmap(BitBtnDC, newWidth, newHeight);
    
      // if new api availble then use it
      if ThemeServices.ThemesAvailable and
         (Windows.SendMessage(BitBtnHandle, BCM_GETIMAGELIST, 0, LPARAM(@ButtonImageList)) <> 0) then
      begin
        // destroy previous bitmap, set new bitmap
        if ButtonImageList.himl <> 0 then
          ImageList_Destroy(ButtonImageList.himl);
        if NewBitmap <> 0 then
        begin
          if ThemeServices.ThemesEnabled then
            if AlphaDraw then
              ButtonImageList.himl := ImageList_Create(newWidth, newHeight, ILC_COLOR32, 5, 0)
            else
              ButtonImageList.himl := ImageList_Create(newWidth, newHeight, ILC_COLORDDB or ILC_MASK, 5, 0)
          else
            ButtonImageList.himl := ImageList_Create(newWidth, newHeight, ILC_COLORDDB or ILC_MASK, 1, 0);
          ButtonImageList.margin.left := 0; //5;
          ButtonImageList.margin.right := 0; //5;
          ButtonImageList.margin.top := 0; //5;
          ButtonImageList.margin.bottom := 0; //5;
          if (BitBtn.Margin = -1) then
            ButtonImageList.uAlign := BUTTON_IMAGELIST_ALIGN_CENTER
          else
            ButtonImageList.uAlign := ord(BitBtnLayout);
          // if themes are enabled then we need to fill all state bitmaps,
          // else fill only current state bitmap
          if ThemeServices.ThemesEnabled then
          begin
            for I := 1 to 6 do
            begin
              DrawBitmap(XPBitBtn_ImageIndexToState[I], True, AlphaDraw);
              if AlphaDraw then
                ImageList_Add(ButtonImageList.himl, NewBitmap, 0)
              else
                ImageList_AddMasked(ButtonImageList.himl, NewBitmap, GetSysColor(COLOR_BTNFACE));
            end;
          end
          else
          begin
            DrawBitmap(BitBtnEnabledToButtonState[IsWindowEnabled(BitBtnHandle) or (csDesigning in BitBtn.ComponentState)], True, False);
            ImageList_AddMasked(ButtonImageList.himl, NewBitmap, GetSysColor(COLOR_BTNFACE));
          end;
        end
        else
        begin
          ButtonImageList.himl := 0;
        end;
        Windows.SendMessage(BitBtnHandle, BCM_SETIMAGELIST, 0, LPARAM(@ButtonImageList));
        if NewBitmap <> 0 then
          DeleteObject(NewBitmap);
      end else
      begin
        OldBitmap := HBITMAP(Windows.SendMessage(BitBtnHandle, BM_GETIMAGE, IMAGE_BITMAP, 0));
    
        if NewBitmap <> 0 then
          DrawBitmap(BitBtnEnabledToButtonState[IsWindowEnabled(BitBtnHandle) or (csDesigning in BitBtn.ComponentState)], False, False);
        Windows.SendMessage(BitBtnHandle, BM_SETIMAGE, IMAGE_BITMAP, LPARAM(NewBitmap));
        if OldBitmap <> 0 then
          DeleteObject(OldBitmap);
      end;
      
      //2020-02-08 zhangch2010
      if NewBitmap <> 0 then
         BitBtn.NewBitmap:= NewBitmap;
    
      DeleteDC(hdcNewBitmap);
      ReleaseDC(BitBtnHandle, BitBtnDC);
      BitBtn.Invalidate;
    end;
    
    function BitBtnWndProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
        LParam: Windows.LParam): LResult; stdcall;
    var
      Info: PWin32WindowInfo;
      Control: TWinControl;
      ButtonImageList: BUTTON_IMAGELIST;
      ImageList: HIMAGELIST;
      LMessage: TLMessage;
    begin
      Info := GetWin32WindowInfo(Window);
      if (Info = nil) or (Info^.WinControl = nil) then
      begin
        Result := CallDefaultWindowProc(Window, Msg, WParam, LParam);
        Exit;
      end
      else
        Control := Info^.WinControl;
    
      case Msg of
        WM_DESTROY:
          begin
            if Assigned(ThemeServices) and ThemeServices.ThemesAvailable and
               (Windows.SendMessage(Window, BCM_GETIMAGELIST, 0, Windows.LPARAM(@ButtonImageList)) <> 0) then
            begin
              // delete and destroy button imagelist
              if ButtonImageList.himl <> 0 then
              begin
                ImageList:=ButtonImageList.himl;
                ButtonImageList.himl:=0;
                Windows.SendMessage(Window, BCM_SETIMAGELIST, 0, Windows.LPARAM(@ButtonImageList));
                ImageList_Destroy(ImageList);
              end;
            end;
            Result := WindowProc(Window, Msg, WParam, LParam);
          end;
        WM_GETFONT:
          begin
            Result := LResult(Control.Font.Reference.Handle);
          end;
        WM_UPDATEUISTATE:
          begin
            Result := WindowProc(Window, Msg, WParam, LParam);
            DrawBitBtnImage(TBitBtn(Control), TBitBtn(Control).Caption);
          end;
        WM_PAINT,
        WM_ERASEBKGND:
          begin
            if not Control.DoubleBuffered then
            begin
              LMessage.msg := Msg;
              LMessage.wParam := WParam;
              LMessage.lParam := LParam;
              LMessage.Result := 0;
              Result := DeliverMessage(Control, LMessage);
            end
            else
              Result := WindowProc(Window, Msg, WParam, LParam);
          end;
        WM_PRINTCLIENT:
          Result := CallDefaultWindowProc(Window, Msg, WParam, LParam);
        else
          Result := WindowProc(Window, Msg, WParam, LParam);
      end;
    end;
    
    
    class function TWin32WSBitBtn.CreateHandle(const AWinControl: TWinControl;
      const AParams: TCreateParams): HWND;
    var
      Params: TCreateWindowExParams;
    begin
      // general initialization of Params
      PrepareCreateWindow(AWinControl, AParams, Params);
      // customization of Params
      with Params do
      begin
        pClassName := @ButtonClsName[0];
        Flags := Flags or BS_BITMAP;
        WindowTitle := '';
        SubClassWndProc := @BitBtnWndProc;
      end;
      // create window
      FinishCreateWindow(AWinControl, Params, false);
      Result := Params.Window;
    end;
    
    class procedure TWin32WSBitBtn.GetPreferredSize(const AWinControl: TWinControl;
      var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean);
    var
      BitBtn: TBitBtn absolute AWinControl;
      spacing, srcWidth, AIndex: integer;
      AImageRes: TScaledImageListResolution;
      AEffect: TGraphicsDrawEffect;
    begin
      if MeasureText(AWinControl, AWinControl.Caption, PreferredWidth, PreferredHeight) then
      begin
        if BitBtn.CanShowGlyph(True) then
        begin
          TBitBtnAceess(BitBtn).FButtonGlyph.GetImageIndexAndEffect(Low(TButtonState), BitBtn.Font.PixelsPerInch, 1,
            AImageRes, AIndex, AEffect);
          srcWidth := AImageRes.Width;
          if BitBtn.Spacing = -1 then
            spacing := 8
          else
            spacing := BitBtn.Spacing;
          if BitBtn.Layout in [blGlyphLeft, blGlyphRight] then
          begin
            Inc(PreferredWidth, spacing + srcWidth);
            if AImageRes.Height > PreferredHeight then
              PreferredHeight := AImageRes.Height;
          end else begin
            Inc(PreferredHeight, spacing + AImageRes.Height);
            if srcWidth > PreferredWidth then
              PreferredWidth := srcWidth;
          end;
        end;
        Inc(PreferredWidth, 20);
        Inc(PreferredHeight, 4);
        if WithThemeSpace then
        begin
          Inc(PreferredWidth, 6);
          Inc(PreferredHeight, 6);
        end;
      end;
    end;
    
    class procedure TWin32WSBitBtn.SetBounds(const AWinControl: TWinControl;
      const ALeft, ATop, AWidth, AHeight: integer);
    begin
      if not WSCheckHandleAllocated(AWinControl, 'SetBounds') then Exit;
      TWin32WSWinControl.SetBounds(AWinControl, ALeft, ATop, AWidth, AHeight);
      if TCustomBitBtn(AWinControl).Spacing = -1 then
        DrawBitBtnImage(TCustomBitBtn(AWinControl), AWinControl.Caption);
    end;
    
    class procedure TWin32WSBitBtn.SetBiDiMode(const AWinControl: TWinControl;
      UseRightToLeftAlign, UseRightToLeftReading, UseRightToLeftScrollBar: Boolean);
    begin
      DrawBitBtnImage(TCustomBitBtn(AWinControl), AWinControl.Caption);
    end;
    
    class procedure TWin32WSBitBtn.SetColor(const AWinControl: TWinControl);
    begin
      if not WSCheckHandleAllocated(AWinControl, 'SetColor') then Exit;
      TWin32WSWinControl.SetColor(AWinControl);
      DrawBitBtnImage(TCustomBitBtn(AWinControl), AWinControl.Caption);
    end;
    
    class procedure TWin32WSBitBtn.SetFont(const AWinControl: TWinControl;
      const AFont: TFont);
    begin
      if not WSCheckHandleAllocated(AWinControl, 'SetFont') then Exit;
      TWin32WSWinControl.SetFont(AWinControl, AFont);
      DrawBitBtnImage(TCustomBitBtn(AWinControl), AWinControl.Caption);
    end;
    
    class procedure TWin32WSBitBtn.SetGlyph(const ABitBtn: TCustomBitBtn;
      const AValue: TButtonGlyph);
    begin
      if not WSCheckHandleAllocated(ABitBtn, 'SetGlyph') then Exit;
      DrawBitBtnImage(ABitBtn, ABitBtn.Caption);
    end;
    
    class procedure TWin32WSBitBtn.SetLayout(const ABitBtn: TCustomBitBtn;
      const AValue: TButtonLayout);
    begin
      if not WSCheckHandleAllocated(ABitBtn, 'SetLayout') then Exit;
      DrawBitBtnImage(ABitBtn, ABitBtn.Caption);
    end;
    
    class procedure TWin32WSBitBtn.SetMargin(const ABitBtn: TCustomBitBtn;
      const AValue: Integer);
    begin
      if not WSCheckHandleAllocated(ABitBtn, 'SetMargin') then Exit;
      DrawBitBtnImage(ABitBtn, ABitBtn.Caption);
    end;
    
    class procedure TWin32WSBitBtn.SetSpacing(const ABitBtn: TCustomBitBtn;
      const AValue: Integer);
    begin
      if not WSCheckHandleAllocated(ABitBtn, 'SetSpacing') then Exit;
      DrawBitBtnImage(ABitBtn, ABitBtn.Caption);
    end;
    
    class procedure TWin32WSBitBtn.SetText(const AWinControl: TWinControl; const AText: string);
    begin
      if not WSCheckHandleAllocated(AWinControl, 'SetText') then Exit;
      //TWin32WSWinControl.SetText(AWinControl, AText);
      DrawBitBtnImage(TCustomBitBtn(AWinControl), AText);
    end;
    
    end.
    
    win32wsbuttons.pp (25,136 bytes)
  • 2020-02-18 BitButton leaks.patch (1,456 bytes)
    Index: lcl/buttons.pp
    ===================================================================
    --- lcl/buttons.pp	(版本 62643)
    +++ lcl/buttons.pp	(工作副本)
    @@ -204,6 +204,8 @@
         procedure LoadGlyphFromStock(idButton: Integer);
         function CanShowGlyph(const AWithShowMode: Boolean = False): Boolean;
       public
    +  
    +	NewBitmap: HBITMAP; // Handle of the new bitmap
         property Caption stored IsCaptionStored;
         property DefaultCaption: Boolean read FDefaultCaption write FDefaultCaption default False;
         property Glyph: TBitmap read GetGlyph write SetGlyph stored IsGlyphStored;
    Index: lcl/include/bitbtn.inc
    ===================================================================
    --- lcl/include/bitbtn.inc	(版本 62643)
    +++ lcl/include/bitbtn.inc	(工作副本)
    @@ -37,6 +37,11 @@
     begin
       FreeThenNil(FButtonGlyph);
       FreeAndNil(FImageChangeLink);
    +  
    +  if NewBitmap <>0 then begin
    +    DeleteObject(NewBitmap);
    +  end;
    +	
       inherited Destroy;
     end;
     
    Index: lcl/interfaces/win32/win32wsbuttons.pp
    ===================================================================
    --- lcl/interfaces/win32/win32wsbuttons.pp	(版本 62643)
    +++ lcl/interfaces/win32/win32wsbuttons.pp	(工作副本)
    @@ -477,6 +477,9 @@
         if OldBitmap <> 0 then
           DeleteObject(OldBitmap);
       end;
    +  if NewBitmap <> 0 then
    +     BitBtn.NewBitmap:= NewBitmap;
    +	 
       DeleteDC(hdcNewBitmap);
       ReleaseDC(BitBtnHandle, BitBtnDC);
       BitBtn.Invalidate;
    

Activities

zhangch2010

2020-02-07 16:53

reporter  

demo.zip (583,405 bytes)
ok.PNG (149,054 bytes)
ok.PNG (149,054 bytes)
NG.PNG (130,800 bytes)
NG.PNG (130,800 bytes)

Anton Kavalenka

2020-02-07 17:09

reporter   ~0120920

Last edited: 2020-02-07 17:20

View 3 revisions

Нічога не зразумела!

Bitbtn exception after opening the form multiple times

A form repeated the test open and close, bitbtn exception after 300+ times

Martin Friebe

2020-02-07 20:26

manager   ~0120927

Checked with ProcessExplorer. Each time the form opens/closes more GDI objects are used.

zhangch2010

2020-02-08 11:59

reporter   ~0120941

unit Win32WSButtons
-----------------------------------------------------

if (newWidth = 0) or (newHeight = 0) then
    NewBitmap := 0
  else
  if AlphaDraw then
    NewBitmap := Create32BitHBitmap(BitBtnDC, newWidth, newHeight, RGBA)
  else
    NewBitmap := CreateCompatibleBitmap(BitBtnDC, newWidth, newHeight);

    {.......................}

  DeleteDC(hdcNewBitmap);
  ReleaseDC(BitBtnHandle, BitBtnDC);
  BitBtn.Invalidate;
end;

NewBitmap not free ?

pic1.PNG (46,636 bytes)
pic1.PNG (46,636 bytes)

zhangch2010

2020-02-08 16:58

reporter   ~0120944

1:lazarus\lcl\interfaces\win32\win32wsbuttons.pp
  //2020-02-08 zhangch2010
  if NewBitmap <> 0 then
     BitBtn.NewBitmap:= NewBitmap;

2:lazarus\lcl\include\bitbtn.inc
    //2020-02-08 zhangch2010
  if NewBitmap <>0 then begin
    DeleteObject(NewBitmap);
    end;

3:lazarus\lcl\buttons.pp
    //2020-02-08 zhangch2010
    NewBitmap: HBITMAP; // Handle of the new bitmap

ok-2.PNG (127,447 bytes)
ok-2.PNG (127,447 bytes)
bitbtn.inc (11,125 bytes)
{%MainUnit ../buttons.pp}

{
 *****************************************************************************
  This file is part of the Lazarus Component Library (LCL)

  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************
}

{------------------------------------------------------------------------------
       TCustomBitBtn Constructor
------------------------------------------------------------------------------}
constructor TCustomBitBtn.Create(TheOwner: TComponent);
begin
  inherited Create(TheOwner);
  FCompStyle := csBitBtn;
  FDefaultCaption := False;
  FKind := bkCustom;
  FLayout := blGlyphLeft;
  FSpacing := 4;
  FMargin := -1;
  FButtonGlyph := TButtonGlyph.Create;
  FButtonGlyph.NumGlyphs := 1;
  FButtonGlyph.OnChange := @GlyphChanged;
  FButtonGlyph.IsDesigning := csDesigning in ComponentState;
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := @ImageListChange;
  Align := alNone;
end;

{------------------------------------------------------------------------------
       TCustomBitBtn destructor
------------------------------------------------------------------------------}
destructor TCustomBitBtn.Destroy;
begin
  FreeAndNil(FButtonGlyph);
  FreeAndNil(FImageChangeLink);
  FreeAndNil(BitBtnImages);
  
   //2020-02-08 zhangch2010
  if NewBitmap <>0 then begin
    DeleteObject(NewBitmap);
    end;

  inherited Destroy;
end;

procedure TCustomBitBtn.Click;
var
  Form : TCustomForm;
begin
  { A TBitBtn with Kind = bkClose should
    - Close the ParentForm if ModalResult = mrNone.
      It should not set ParentForm.ModalResult in this case
    - Close a non-modal ParentForm if ModalResult in [mrNone, mrClose]
    - on nested forms it will close the non docked form
    - In all other cases it should behave like any other TBitBtn
  }
  if (FKind = bkClose) then
  begin
    Form := GetTopFormSkipNonDocked(Self);
    if (Form <> nil) then
    begin
      if (ModalResult = mrNone) or
         ((ModalResult = mrClose) and not (fsModal in Form.FormState)) then
      begin
        Form.Close;
        Exit;
      end;
    end;
  end;
  inherited Click;
end;

procedure TCustomBitBtn.LoadGlyphFromResourceName(Instance: THandle; const AName: String);
begin
  Buttons.LoadGlyphFromResourceName(FButtonGlyph, Instance, AName);
end;

procedure TCustomBitBtn.LoadGlyphFromLazarusResource(const AName: String);
begin
  Buttons.LoadGlyphFromLazarusResource(FButtonGlyph, AName);
end;

procedure TCustomBitBtn.LoadGlyphFromStock(idButton: Integer);
begin
  Buttons.LoadGlyphFromStock(FButtonGlyph, idButton);
end;

procedure TCustomBitBtn.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FButtonGlyph <> nil) and (AComponent = FButtonGlyph.ExternalImages) then
    Images := nil;
end;

function TCustomBitBtn.CanShowGlyph(const AWithShowMode: Boolean): Boolean;
begin
  Result := FButtonGlyph.CanShowGlyph;
  if AWithShowMode then
    Result := Result and FButtonGlyph.CanShow;
end;

function TCustomBitBtn.GetGlyph : TBitmap;
begin
  Result := FButtonGlyph.Glyph;
end;

function TCustomBitBtn.GetGlyphShowMode: TGlyphShowMode;
begin
  Result := FButtonGlyph.ShowMode;
end;

function TCustomBitBtn.GetImageIndex: TImageIndex;
begin
  Result := FButtonGlyph.ExternalImageIndex;
end;

function TCustomBitBtn.GetImages: TCustomImageList;
begin
  Result := FButtonGlyph.ExternalImages;
end;

function TCustomBitBtn.GetImageWidth: Integer;
begin
  Result := FButtonGlyph.ExternalImageWidth;
end;

function TCustomBitBtn.GetNumGlyphs: Integer;
begin
  Result := FButtonGlyph.FNumGlyphs;
end;

function TCustomBitBtn.IsGlyphStored: Boolean;
var
  act: TCustomAction;
begin
  if Action <> nil then
  begin
    result := true;
    act := TCustomAction(Action);
    if (act.ActionList <> nil) and (act.ActionList.Images <> nil) and
      (act.ImageIndex >= 0) and (act.ImageIndex < act.ActionList.Images.Count) then
        result := false;
  end 
  else Result := (Kind = bkCustom) and (FButtonGlyph.Glyph <> nil)
    and (not FButtonGlyph.Glyph.Empty)
      and (FButtonGlyph.Glyph.Width>0) and (FButtonGlyph.Glyph.Height>0);
end;

procedure TCustomBitBtn.SetGlyph(AValue: TBitmap);
begin
  FButtonGlyph.Glyph := AValue;
  InvalidatePreferredSize;
  AdjustSize;
end;

procedure TCustomBitBtn.SetGlyphShowMode(const AValue: TGlyphShowMode);
begin
  FButtonGlyph.ShowMode := AValue;
end;

procedure TCustomBitBtn.SetImageIndex(const aImageIndex: TImageIndex);
begin
  FButtonGlyph.ExternalImageIndex := aImageIndex;
end;

procedure TCustomBitBtn.SetImages(const aImages: TCustomImageList);
begin
  if FButtonGlyph.ExternalImages <> nil then
  begin
    FButtonGlyph.ExternalImages.UnRegisterChanges(FImageChangeLink);
    FButtonGlyph.ExternalImages.RemoveFreeNotification(Self);
  end;
  FButtonGlyph.ExternalImages := aImages;
  if FButtonGlyph.ExternalImages <> nil then
  begin
    FButtonGlyph.ExternalImages.FreeNotification(Self);
    FButtonGlyph.ExternalImages.RegisterChanges(FImageChangeLink);
  end;
  InvalidatePreferredSize;
  AdjustSize;
end;

procedure TCustomBitBtn.SetImageWidth(const aImageWidth: Integer);
begin
  FButtonGlyph.ExternalImageWidth := aImageWidth;
  InvalidatePreferredSize;
  AdjustSize;
end;

procedure TCustomBitBtn.GlyphChanged(Sender: TObject);
begin
  if HandleAllocated then
    TWSBitBtnClass(WidgetSetClass).SetGlyph(Self, FButtonGlyph);
  InvalidatePreferredSize;
  AdjustSize;
end;

procedure TCustomBitBtn.ImageListChange(Sender: TObject);
begin
  if Sender = Images then
    GlyphChanged(Sender);
end;

procedure TCustomBitBtn.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
  inherited ActionChange(Sender,CheckDefaults);
  if Sender is TCustomAction then
  begin
    with TCustomAction(Sender) do
    begin
      if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
        (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
        ActionList.Images.GetBitmap(ImageIndex, Glyph);
    end;
  end;
end;

procedure TCustomBitBtn.SetKind(AValue: TBitBtnKind);
begin
  if FKind = AValue then Exit;
  FKind := AValue;
  if (FKind <> bkCustom) and not (csLoading in ComponentState) then
    RealizeKind(True);
  if not (csLoading in ComponentState) then
    DefaultCaption := FKind <> bkCustom;
end;

procedure TCustomBitBtn.SetLayout(AValue: TButtonLayout);
begin
  if FLayout = AValue then Exit;
  FLayout := AValue;
  if HandleAllocated then
  begin
    TWSBitBtnClass(WidgetSetClass).SetLayout(Self, FLayout);
    InvalidatePreferredSize;
  end;
  AdjustSize;
end;

procedure TCustomBitBtn.SetMargin(const AValue: integer);
begin
  if FMargin = AValue then Exit;
  FMargin := AValue;
  if HandleAllocated  then
    TWSBitBtnClass(WidgetSetClass).SetMargin(Self, FMargin);
  AdjustSize;
  if csDesigning in ComponentState then
    Invalidate;
end;

procedure TCustomBitBtn.SetNumGlyphs(AValue: Integer);
begin
  if AValue < Low(TNumGlyphs) then AValue := Low(TNumGlyphs);
  if AValue > High(TNumGlyphs) then AValue := High(TNumGlyphs);

  if AValue <> FButtonGlyph.NumGlyphs then
  Begin
    FButtonGlyph.NumGlyphs := TNumGlyphs(AValue);
    Invalidate;
  end;
end;

procedure TCustomBitBtn.SetSpacing(AValue: Integer);
begin
  if (FSpacing = AValue) or (AValue < -1) then Exit;
  FSpacing := AValue;
  if HandleAllocated then
    TWSBitBtnClass(WidgetSetClass).SetSpacing(Self, FSpacing);
  AdjustSize;
  if csDesigning in ComponentState then
    Invalidate;
end;

procedure TCustomBitBtn.RealizeKind(ForceDefaults: Boolean);
var
  GlyphValid, Handled: Boolean;
  CustomGlyph: TGraphic;
  BitmapHandle, MaskHandle: HBitmap;
  idButton: LongInt;
begin
  if (Kind <> bkCustom) then
  begin
    GlyphValid := False;
    
    // first let the user override
    if GetDefaultBitBtnGlyph <> nil then
    begin
      Handled := False;
      CustomGlyph := GetDefaultBitBtnGlyph(Kind, Handled);
      if Handled then
      begin
        Glyph.Assign(CustomGlyph);
        CustomGlyph.Free;
        GlyphValid := True;
      end;
    end;

    // then ask the widgetset
    if not GlyphValid then 
    begin
      if ThemeServices.GetStockImage(BitBtnImages[Kind], BitmapHandle, MaskHandle) then
      begin
        Glyph.Handle := BitmapHandle;
        Glyph.MaskHandle := MaskHandle;
        GlyphValid := True;
      end;
    end;
    
    if not GlyphValid then
    begin
      if ForceDefaults or (Images=nil) then
      begin
        idButton := BitBtnImages[Kind];
        if (idButton >= Low(BitBtnResNames)) and (idButton <= High(BitBtnResNames))
        and (BitBtnResNames[idButton] <> '') then
          FButtonGlyph.LCLGlyphName := BitBtnResNames[idButton]
        else
          ImageIndex := -1;
        GlyphValid := True;
      end;
    end;
  end;

  if ForceDefaults then
  begin
    Caption := GetCaptionOfKind(Kind);
    ModalResult := BitBtnModalResults[Kind];
    Default := Kind in [bkOk, bkYes];
    Cancel := Kind in [bkCancel, bkNo];
  end;
end;

{ Return the caption associated with the akind value.
  This function replaces BitBtnCaption const because the localizing
  do not work with an const array }
function TCustomBitBtn.GetCaptionOfKind(AKind: TBitBtnKind): String;
begin
  Result := GetButtonCaption(BitBtnImages[Kind]);
  if Result = '?' then
    Result := '';
end;

class procedure TCustomBitBtn.WSRegisterClass;
begin
  inherited WSRegisterClass;
  RegisterCustomBitBtn;
end;

procedure TCustomBitBtn.InitializeWnd;
begin
  inherited InitializeWnd;
  TWSBitBtnClass(WidgetSetClass).SetGlyph(Self, FButtonGlyph);
  TWSBitBtnClass(WidgetSetClass).SetLayout(Self, FLayout);
  TWSBitBtnClass(WidgetSetClass).SetMargin(Self, FMargin);  
  TWSBitBtnClass(WidgetSetClass).SetSpacing(Self, FSpacing);  
end;

function TCustomBitBtn.IsCaptionStored: Boolean;
begin
  Result := inherited IsCaptionStored and not DefaultCaption;
end;

procedure TCustomBitBtn.Loaded;
begin
  inherited Loaded;
  if (Kind <> bkCustom) then
    RealizeKind(False);
  if (Kind <> bkCustom) and DefaultCaption and (Caption = '') then
  begin
    Caption := GetCaptionOfKind(Kind); // Will trigger TextChanged
    DefaultCaption := True;
  end;
end;

procedure TCustomBitBtn.TextChanged;
begin
  inherited TextChanged;
  AdjustSize;
  DefaultCaption := False;
end;

class function TCustomBitBtn.GetControlClassDefaultSize: TSize;
begin
  Result.CX := 75;
  Result.CY := 30;
end;

procedure TCustomBitBtn.CMAppShowBtnGlyphChanged(var Message: TLMessage);
begin
  if GlyphShowMode = gsmApplication then
    FButtonGlyph.Refresh;
end;

// included by buttons.pp
bitbtn.inc (11,125 bytes)
buttons.pp (23,593 bytes)
{ $Id: buttons.pp 58244 2018-06-13 13:59:07Z juha $}

{
 /***************************************************************************
                                 buttons.pp
                                 ----------
                             Component Library Code


                   Initial Revision : Sun Mar 28 23:15:32 CST 1999
                   Revised: Sat Jul 3 1999

 ***************************************************************************/

 *****************************************************************************
  This file is part of the Lazarus Component Library (LCL)

  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************
}

unit Buttons;

{$mode objfpc}{$H+}

interface

{$ifdef Trace}
{$ASSERTIONS ON}
{$endif}

uses
  Types, Classes, SysUtils, Math,
  // LCL
  LCLType, LCLProc, LCLIntf, LCLStrConsts,
  GraphType, Graphics, ImgList, ActnList, Controls, StdCtrls, LMessages, Forms,
  Themes, Menus, LResources, ImageListCache,
  // LazUtils
  LazUtilities;

type
  TButtonLayout =
  (
    blGlyphLeft,
    blGlyphRight,
    blGlyphTop,
    blGlyphBottom
  );

  TButtonState =
  (
    bsUp,       // button is up
    bsDisabled, // button disabled (grayed)
    bsDown,     // button is down
    bsExclusive,// button is the only down in his group
    bsHot       // button is under mouse
  );

  {
   TNumGlyphs holds the number of glyphs in an image.
   If we change this the code in SetNumGlyphs for @link(TCustomSpeedButton)
   needs to be changed
  }
  TNumGlyphs = 1..5;

  { TButtonGlyph }
  TGlyphTransparencyMode = (
    gtmGlyph,       // transparency is defined by the glyph itself (bitbtn)
    gtmOpaque,      // transparent = false is defined by the owner (speedbutton)
    gtmTransparent  // transparent = true
  );

  TButtonGlyph = class(TObject, IUnknown, IImageCacheListener)
  private
    FIsDesigning: Boolean;
    FShowMode: TGlyphShowMode;
    FImageIndexes: array[TButtonState] of Integer;
    FImages: TCustomImageList;
    FExternalImages: TCustomImageList;
    FExternalImageIndex: Integer;
    FExternalImageWidth: Integer;
    FLCLGlyphResourceName: string;
    FOriginal: TBitmap;
    FNumGlyphs: TNumGlyphs;
    FOnChange: TNotifyEvent;
    FImagesCache: TImageListCache;
    FTransparentMode: TGlyphTransparencyMode;         // set by our owner to indicate that the glyphbitmap should be transparent
    FLCLGlyphName: string;
    function GetHeight: Integer;
    function GetNumGlyphs: TNumGlyphs;
    function GetWidth: Integer;
    procedure SetExternalImageIndex(const AExternalImageIndex: Integer);
    procedure SetExternalImages(const AExternalImages: TCustomImageList);
    procedure SetExternalImageWidth(const AExternalImageWidth: Integer);
    procedure SetGlyph(Value: TBitmap);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure SetShowMode(const AValue: TGlyphShowMode);
    procedure ClearImages;
    procedure ClearLCLGlyph;
    procedure SetLCLGlyphName(const ALCLGlyphName: string);
  public
    // IUnknown
    function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
    function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
    function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
    // IImageCacheListener
    procedure CacheSetImageList(AImageList: TCustomImageList);
    procedure CacheSetImageIndex(AIndex, AImageIndex: Integer);
  protected
    function CanShow: Boolean;
    function CanShowGlyph: Boolean;
    procedure DoChange; virtual;
    procedure GlyphChanged(Sender: TObject);
    procedure SetTransparentMode(AValue: TGlyphTransparencyMode);
    
    property TransparentMode: TGlyphTransparencyMode read FTransparentMode;
  public
    constructor Create;
    destructor Destroy; override;
    procedure GetImageIndexAndEffect(State: TButtonState;
      APPI: Integer; const ACanvasScaleFactor: Double;
      out AImageResolution: TScaledImageListResolution;
      out AIndex: Integer; out AEffect: TGraphicsDrawEffect);
    function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
                  State: TButtonState; Transparent: Boolean;
                  BiDiFlags: Longint): TRect;
    function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
                  State: TButtonState; Transparent: Boolean;
                  BiDiFlags, PPI: Longint; const ScaleFactor: Double): TRect;
    procedure Refresh;
    property Glyph: TBitmap read FOriginal write SetGlyph;
    property IsDesigning: Boolean read FIsDesigning write FIsDesigning;
    property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs;
    property Images: TCustomImageList read FImages;
    property LCLGlyphName: string read FLCLGlyphName write SetLCLGlyphName;
    property ExternalImages: TCustomImageList read FExternalImages write SetExternalImages;
    property ExternalImageIndex: Integer read FExternalImageIndex write SetExternalImageIndex;
    property ExternalImageWidth: Integer read FExternalImageWidth write SetExternalImageWidth;
    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
    property ShowMode: TGlyphShowMode read FShowMode write SetShowMode;
  public
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;


  { TCustomBitBtn }

  // when adding items here, also update TBitBtn.GetCaptionOfKind
  TBitBtnKind = (bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo,
                 bkClose, bkAbort, bkRetry, bkIgnore, bkAll,
                 bkNoToAll, bkYesToAll);
  TBitBtnKinds = set of TBitBtnKind;

  TCustomBitBtn = class(TCustomButton)
  private
    FDefaultCaption: Boolean;
    FKind: TBitBtnKind;
    FLayout: TButtonLayout;
    FMargin: integer;
    FSpacing: Integer;
    FImageChangeLink: TChangeLink;
    function GetGlyph: TBitmap;
    function GetGlyphShowMode: TGlyphShowMode;
    function GetNumGlyphs: Integer;
    procedure ImageListChange(Sender: TObject);
    function IsGlyphStored: Boolean;
    procedure SetGlyph(AValue: TBitmap);
    procedure SetGlyphShowMode(const AValue: TGlyphShowMode);
    procedure SetKind(AValue: TBitBtnKind);
    procedure SetLayout(AValue: TButtonLayout);
    procedure SetMargin(const AValue: integer);
    procedure SetNumGlyphs(AValue: Integer);
    procedure SetSpacing(AValue: Integer);
    procedure RealizeKind(ForceDefaults: Boolean);
    //Return the caption associated with the aKind value.
    function GetCaptionOfKind(AKind: TBitBtnKind): String;
    function GetImages: TCustomImageList;
    procedure SetImages(const aImages: TCustomImageList);
    function GetImageIndex: TImageIndex;
    procedure SetImageIndex(const aImageIndex: TImageIndex);
    function GetImageWidth: Integer;
    procedure SetImageWidth(const aImageWidth: Integer);
  protected

    FButtonGlyph: TButtonGlyph;
    class procedure WSRegisterClass; override;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    procedure GlyphChanged(Sender: TObject);
    procedure InitializeWnd; override;
    function IsCaptionStored: Boolean;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure TextChanged; override;
    class function GetControlClassDefaultSize: TSize; override;
    procedure CMAppShowBtnGlyphChanged(var Message: TLMessage); message CM_APPSHOWBTNGLYPHCHANGED;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    procedure LoadGlyphFromResourceName(Instance: THandle; const AName: String);
    procedure LoadGlyphFromLazarusResource(const AName: String);
    procedure LoadGlyphFromStock(idButton: Integer);
    function CanShowGlyph(const AWithShowMode: Boolean = False): Boolean;
  public
  
    //2020-02-08 zhangch2010
    NewBitmap: HBITMAP; // Handle of the new bitmap
	
    property Caption stored IsCaptionStored;
    property DefaultCaption: Boolean read FDefaultCaption write FDefaultCaption default False;
    property Glyph: TBitmap read GetGlyph write SetGlyph stored IsGlyphStored;
    property NumGlyphs: Integer read GetNumGlyphs write SetNumGlyphs default 1;
    property Images: TCustomImageList read GetImages write SetImages;
    property ImageIndex: TImageIndex read GetImageIndex write SetImageIndex default -1;
    property ImageWidth: Integer read GetImageWidth write SetImageWidth default 0;
    property Kind: TBitBtnKind read FKind write SetKind default bkCustom;
    property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
    property Margin: integer read FMargin write SetMargin default -1;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property GlyphShowMode: TGlyphShowMode read GetGlyphShowMode write SetGlyphShowMode default gsmApplication;
  end;

  { TBitBtn }
  { To set custom bitbtn glyphs for the whole application, see below for
    GetDefaultBitBtnGlyph }

  TBitBtn = class(TCustomBitBtn)
  published
    property Action;
    property Align;
    property Anchors;
    property AutoSize;
    property BidiMode;
    property BorderSpacing;
    property Cancel;
    property Caption;
    property Color;
    property Constraints;
    property Default;
    property DefaultCaption;
    property Enabled;
    property Font;
    property Glyph;
    property GlyphShowMode;
    property Kind;
    property Layout;
    property Margin;
    property ModalResult;
    property NumGlyphs;
    property Images;
    property ImageIndex;
    property ImageWidth;
    property OnChangeBounds;
    property OnClick;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnResize;
    property OnStartDrag;
    property OnUTF8KeyPress;
    property ParentBidiMode;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Spacing;
    property TabOrder;
    property TabStop;
    property Visible;
  end;


  { TSpeedButtonActionLink }

  TSpeedButtonActionLink = class(TControlActionLink)
  protected
    procedure AssignClient(AClient: TObject); override;
    procedure SetGroupIndex(Value: Integer); override;
    procedure SetChecked(Value: Boolean); override;
  public
    function IsCheckedLinked: Boolean; override;
    function IsGroupIndexLinked: Boolean; override;
  end;

  { TCustomSpeedButton }

  TCustomSpeedButton = class(TGraphicControl)
  private
    FGlyph: TButtonGlyph;
    FGroupIndex: Integer;
    FImageChangeLink: TChangeLink;
    FLastDrawDetails: TThemedElementDetails;
    FLayout: TButtonLayout;
    FMargin: integer;
    FSpacing: integer;
    FShortcut: TShortCut;
    FShowAccelChar: boolean;
    FShowCaption: boolean;
    FAllowAllUp: Boolean;
    FDown: Boolean;
    FDownLoaded : Boolean;// value of Down set during loading
    FDragging: Boolean;
    FFlat: Boolean;
    FMouseInControl: Boolean;
    function GetGlyph: TBitmap;
    procedure ImageListChange(Sender: TObject);
    function IsGlyphStored: Boolean;
    procedure SetShowCaption(const AValue: boolean);
    procedure UpdateExclusive;
    function  GetTransparent: Boolean;
    procedure SetAllowAllUp(Value: Boolean);
    procedure SetGlyph(Value: TBitmap);
    procedure SetLayout(const Value: TButtonLayout);
    procedure SetShowAccelChar(Value: boolean);
    procedure SetTransparent(const AValue: boolean);
    procedure CMButtonPressed(var Message: TLMessage); message CM_BUTTONPRESSED;
    procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED;
  private
    procedure DoMouseUp(var Message: TLMMouse; Button: TMouseButton);
    procedure WMLButtonDown(Var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
    procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
    procedure WMLButtonDBLCLK(Var Message: TLMLButtonDblClk); message LM_LBUTTONDBLCLK;
    function GetImages: TCustomImageList;
    procedure SetImages(const aImages: TCustomImageList);
    function GetImageIndex: TImageIndex;
    procedure SetImageIndex(const aImageIndex: TImageIndex);
    function GetImageWidth: Integer;
    procedure SetImageWidth(const aImageWidth: Integer);
  protected
    FState: TButtonState;
    class procedure WSRegisterClass; override;
    function ButtonGlyph: TButtonGlyph;
    function GetNumGlyphs: Integer;
    procedure GlyphChanged(Sender: TObject); virtual;
    function  DialogChar(var Message: TLMKey): boolean; override;
    procedure CalculatePreferredSize(var PreferredWidth,
      PreferredHeight: integer; WithThemeSpace: Boolean); override;
    procedure MeasureDraw(Draw: boolean; PaintRect: TRect;
                          out PreferredWidth, PreferredHeight: integer);
    procedure MouseEnter; override;
    procedure MouseLeave; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure Paint; override;
    procedure PaintBackground(var PaintRect: TRect); virtual;
    procedure SetDown(Value: Boolean);
    procedure SetGroupIndex(const Value: Integer);
    procedure SetFlat(const Value: Boolean);
    procedure SetMargin(const Value: integer);
    procedure SetNumGlyphs(Value: integer);
    procedure SetSpacing(const Value: integer);
    procedure RealSetText(const Value: TCaption); override;
    procedure UpdateState(InvalidateOnChange: boolean); virtual;
    function GetDrawDetails: TThemedElementDetails; virtual;
    property MouseInControl: Boolean read FMouseInControl;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    function GetActionLinkClass: TControlActionLinkClass; override;
    class function GetControlClassDefaultSize: TSize; override;
    procedure Loaded; override;
  protected
    function GetGlyphSize(Drawing: boolean; PaintRect: TRect): TSize; virtual;
    function GetTextSize(Drawing: boolean; PaintRect: TRect): TSize; virtual;
    function DrawGlyph(ACanvas: TCanvas; const AClient: TRect; const AOffset: TPoint;
      AState: TButtonState; ATransparent: Boolean; BiDiFlags: Longint): TRect; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function FindDownButton: TCustomSpeedButton;
    procedure Click; override; // make Click public
    procedure LoadGlyphFromResourceName(Instance: THandle; const AName: String);
    procedure LoadGlyphFromLazarusResource(const AName: String);
  public
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default false;
    property Color default clBtnFace;
    property Down: Boolean read FDown write SetDown default false;
    property Flat: Boolean read FFlat write SetFlat default false;
    property Glyph: TBitmap read GetGlyph write SetGlyph stored IsGlyphStored;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
    property Images: TCustomImageList read GetImages write SetImages;
    property ImageIndex: TImageIndex read GetImageIndex write SetImageIndex default -1;
    property ImageWidth: Integer read GetImageWidth write SetImageWidth default 0;
    property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
    property Margin: integer read FMargin write SetMargin default -1;
    property NumGlyphs: Integer read GetNumGlyphs write SetNumGlyphs default 1;
    property ShowAccelChar: boolean read FShowAccelChar write SetShowAccelChar default true;
    property ShowCaption: boolean read FShowCaption write SetShowCaption default true;
    property Spacing: integer read FSpacing write SetSpacing default 4;
    property Transparent: Boolean read GetTransparent write SetTransparent default true;
  end;


  { TSpeedButton }

  TSpeedButton = class(TCustomSpeedButton)
  published
    property Action;
    property Align;
    property AllowAllUp;
    property Anchors;
    property AutoSize;
    property BidiMode;
    property BorderSpacing;
    property Constraints;
    property Caption;
    property Color;
    property Down;
    property Enabled;
    property Flat;
    property Font;
    property Glyph;
    property GroupIndex;
    property Images;
    property ImageIndex;
    property ImageWidth;
    property Layout;
    property Margin;
    property NumGlyphs;
    property Spacing;
    property Transparent;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnPaint;
    property OnResize;
    property OnChangeBounds;
    property ShowCaption;
    property ShowHint;
    property ParentBidiMode;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
  end;

  { To override the default TBitBtn glyphs set GetDefaultBitBtnGlyph below.
    Example:

    function GetBitBtnGlyph(Kind: TBitBtnKind): TBitmap;
    begin
      if Kind in [bkOK, bkCancel] then begin
        Result:=TBitmap.Create;
        case Kind of
          bkOk:      Result.Assign(MyOkGlyph);
          bkCancel:  Result.Assign(MyCancelGlyph);
        end;
      end else
        Result:=nil;
    end;
    }
type
  TGetDefaultBitBtnGlyph = function(Kind: TBitBtnKind; var Handled: Boolean): TBitmap;
var
  GetDefaultBitBtnGlyph: TGetDefaultBitBtnGlyph = nil;

function GetLCLDefaultBtnGlyph(Kind: TBitBtnKind): TGraphic;
procedure LoadGlyphFromResourceName(AGlyph: TButtonGlyph; Instance: THandle; const AName: String);
procedure LoadGlyphFromLazarusResource(AGlyph: TButtonGlyph; const AName: String);
procedure LoadGlyphFromStock(AGlyph: TButtonGlyph; idButton: Integer);

// helper functions (search LCLType for idButton)
function GetButtonCaption(idButton: Integer): String;
function GetDefaultButtonIcon(idButton: Integer; ScalePercent: Integer = 100): TCustomBitmap;
function GetButtonIcon(idButton: Integer): TCustomBitmap;
function BidiAdjustButtonLayout(IsRightToLeft: Boolean; Layout: TButtonLayout): TButtonLayout;

function dbgs(Kind: TBitBtnKind): string; overload;

procedure Register;

const
  BitBtnModalResults: array[TBitBtnKind] of TModalResult = (
    0, mrOK, mrCancel, 0, mrYes, mrNo,
    mrClose, mrAbort, mrRetry, mrIgnore, mrAll,
    mrNoToAll, mrYesToAll);

  BitBtnImages: array[TBitBtnKind] of Longint = (
    idButtonBase, idButtonOk, idButtonCancel, idButtonHelp, idButtonYes,
    idButtonNo, idButtonClose, idButtonAbort, idButtonRetry, idButtonIgnore,
    idButtonAll, idButtonNoToAll, idButtonYesToAll);

  BitBtnResNames: array[idButtonOk..idButtonNoToAll] of String =
  (
{idButtonOk      } 'btn_ok',
{idButtonCancel  } 'btn_cancel',
{idButtonHelp    } 'btn_help',
{idButtonYes     } 'btn_yes',
{idButtonNo      } 'btn_no',
{idButtonClose   } 'btn_close',
{idButtonAbort   } 'btn_abort',
{idButtonRetry   } 'btn_retry',
{idButtonIgnore  } 'btn_ignore',
{idButtonAll     } 'btn_all',
{idButtonYesToAll} 'btn_all',
{idButtonNoToAll } 'btn_no'
  );

implementation

{$R btn_icons.res}

uses
  WSButtons;

function GetLCLDefaultBtnGlyph(Kind: TBitBtnKind): TGraphic;
begin
  Result := GetDefaultButtonIcon(BitBtnImages[Kind]);
end;

function GetDefaultButtonIcon(idButton: Integer;
  ScalePercent: Integer): TCustomBitmap;
var
  ResName: string;
begin
  Result := nil;
  if (idButton < Low(BitBtnResNames)) or (idButton > High(BitBtnResNames)) then
    Exit;
  if BitBtnResNames[idButton] = '' then
    Exit;
  Result := GetDefaultGlyph(BitBtnResNames[idButton], ScalePercent);
end;

procedure LoadGlyphFromResourceName(AGlyph: TButtonGlyph; Instance: THandle; const AName: String);
var
  C: TCustomBitmap;
begin
  if AName = '' then
    C := nil
  else
    C := CreateBitmapFromResourceName(Instance, AName);

  try
    AGlyph.Glyph.Assign(C);
  finally
    C.Free;
  end;
end;

procedure LoadGlyphFromLazarusResource(AGlyph: TButtonGlyph; const AName: String);
var
  C: TCustomBitmap;
begin
  if AName = '' then
    C := nil
  else
    C := CreateBitmapFromLazarusResource(AName);

  try
    AGlyph.Glyph.Assign(C);
  finally
    C.Free;
  end;
end;

procedure LoadGlyphFromStock(AGlyph: TButtonGlyph; idButton: Integer);
var
  C: TCustomBitmap;
begin
  C := GetButtonIcon(idButton);
  try
    AGlyph.Glyph.Assign(C);
  finally
    C.Free;
  end;
end;

function GetButtonCaption(idButton: Integer): String;
begin
  case idButton of
    idButtonOk       : Result := rsmbOK;
    idButtonCancel   : Result := rsmbCancel;
    idButtonHelp     : Result := rsmbHelp;
    idButtonYes      : Result := rsmbYes;
    idButtonNo       : Result := rsmbNo;
    idButtonClose    : Result := rsmbClose;
    idButtonAbort    : Result := rsmbAbort;
    idButtonRetry    : Result := rsmbRetry;
    idButtonIgnore   : Result := rsmbIgnore;
    idButtonAll      : Result := rsmbAll;
    idButtonYesToAll : Result := rsmbYesToAll;
    idButtonNoToAll  : Result := rsmbNoToAll;
    idButtonOpen     : Result := rsmbOpen;
    idButtonSave     : Result := rsmbSave;
    idButtonShield   : Result := rsmbUnlock;
  else
    Result := '?';
  end;
end;

function GetButtonIcon(idButton: Integer): TCustomBitmap;
var
  BitmapHandle, MaskHandle: HBitmap;
begin
  if ThemeServices.GetStockImage(idButton, BitmapHandle, MaskHandle) then
  begin
    Result := TBitmap.Create;
    Result.Handle := BitmapHandle;
    if MaskHandle <> 0 then
      Result.MaskHandle := MaskHandle;
  end
  else
    Result := GetDefaultButtonIcon(idButton);
end;

const
  BtnBidiLayout: array[Boolean, TButtonLayout] of TButtonLayout =
  (
    (
      blGlyphLeft,
      blGlyphRight,
      blGlyphTop,
      blGlyphBottom
    ),
    (
      blGlyphRight,
      blGlyphLeft,
      blGlyphTop,
      blGlyphBottom
    )
  );

function BidiAdjustButtonLayout(IsRightToLeft: Boolean; Layout: TButtonLayout): TButtonLayout;
begin
  Result := BtnBidiLayout[IsRightToLeft, Layout];
end;

function dbgs(Kind: TBitBtnKind): string;
begin
  Result:='';
  writestr(Result,Kind);
end;

procedure Register;
begin
  RegisterComponents('Additional',[TBitBtn,TSpeedButton]);
end;

{$I bitbtn.inc}
{$I buttonglyph.inc}
{$I speedbutton.inc}

end.
buttons.pp (23,593 bytes)
win32wsbuttons.pp (25,136 bytes)
{ $Id: win32wsbuttons.pp 59282 2018-10-09 23:07:37Z maxim $}
{
 *****************************************************************************
 *                             Win32WSButtons.pp                             *
 *                             -----------------                             *
 *                                                                           *
 *                                                                           *
 *****************************************************************************

 *****************************************************************************
  This file is part of the Lazarus Component Library (LCL)

  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************
}
unit Win32WSButtons;

{$mode objfpc}{$H+}
{$I win32defines.inc}

interface

uses
////////////////////////////////////////////////////
// I M P O R T A N T
////////////////////////////////////////////////////
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
  Windows, CommCtrl, Classes, Buttons, Graphics, GraphType, Controls,
  LCLType, LCLMessageGlue, LMessages, LazUTF8, Themes, ImgList,
////////////////////////////////////////////////////
  WSProc, WSButtons, Win32WSControls, Win32WSImgList,
  UxTheme, Win32Themes;

type

  { TWin32WSBitBtn }

  TWin32WSBitBtn = class(TWSBitBtn)
  published
    class function CreateHandle(const AWinControl: TWinControl;
          const AParams: TCreateParams): HWND; override;
    class procedure GetPreferredSize(const AWinControl: TWinControl;
          var PreferredWidth, PreferredHeight: integer;
          WithThemeSpace: Boolean); override;
    class procedure SetBounds(const AWinControl: TWinControl;
          const ALeft, ATop, AWidth, AHeight: integer); override;
    class procedure SetBiDiMode(const AWinControl: TWinControl; UseRightToLeftAlign, UseRightToLeftReading, UseRightToLeftScrollBar : Boolean); override;
    class procedure SetColor(const AWinControl: TWinControl); override;
    class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override;
    class procedure SetGlyph(const ABitBtn: TCustomBitBtn; const AValue: TButtonGlyph); override;
    class procedure SetLayout(const ABitBtn: TCustomBitBtn; const AValue: TButtonLayout); override;
    class procedure SetMargin(const ABitBtn: TCustomBitBtn; const AValue: Integer); override;
    class procedure SetSpacing(const ABitBtn: TCustomBitBtn; const AValue: Integer); override;
    class procedure SetText(const AWinControl: TWinControl; const AText: string); override;
  end;

  { TWin32WSSpeedButton }

  TWin32WSSpeedButton = class(TWSSpeedButton)
  published
  end;

procedure DrawBitBtnImage(BitBtn: TCustomBitBtn; const ButtonCaption: string);

implementation

uses
  Win32Int, Win32Proc;

type
  TBitBtnAceess = class(TCustomBitBtn)
  end;

{ TWin32WSBitBtn }

const
  { - you do need to destroy the imagelist yourself.
    - you'll need 5 images to support all themed xp button states...

    Image 0 = NORMAL
    Image 1 = HOT
    Image 2 = PRESSED
    Image 3 = DISABLED
    Image 4 = DEFAULTED
    Image 5 = STYLUSHOT - for tablet computers
  }

  XPBitBtn_ImageIndexToState: array[1..6] of TButtonState =
    (bsUp, bsHot, bsDown, bsDisabled, bsUp, bsHot);
  BitBtnEnabledToButtonState: array[boolean] of TButtonState =
    (bsDisabled, bsUp);

function Create32BitHBitmap(ADC: HDC; AWidth, AHeight: Integer; out BitsPtr: Pointer): HBitmap;
var
  Info: Windows.TBitmapInfo;
begin
  FillChar(Info, SizeOf(Info), 0);
  Info.bmiHeader.biSize := SizeOf(Info.bmiHeader);
  Info.bmiHeader.biWidth := AWidth;
  Info.bmiHeader.biHeight := -AHeight; // top down
  Info.bmiHeader.biPlanes := 1;
  Info.bmiHeader.biBitCount := 32;
  Info.bmiHeader.biCompression := BI_RGB;
  BitsPtr := nil;
  Result := Windows.CreateDIBSection(ADC, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS, BitsPtr, 0, 0);
end;

{------------------------------------------------------------------------------
  Method: DrawBitBtnImage
  Params:  BitBtn: The TCustomBitBtn to update the image of
           ButtonCaption: new button caption
  Returns: Nothing

  Updates the button image combining the glyph and caption
 ------------------------------------------------------------------------------}
procedure DrawBitBtnImage(BitBtn: TCustomBitBtn; const ButtonCaption: string);
var
  BitBtnLayout: TButtonLayout; // Layout of button and glyph
  BitBtnHandle: HWND; // Handle to bitbtn window
  BitBtnDC: HDC; // Handle to DC of bitbtn window
  OldFontHandle: HFONT; // Handle of previous font in hdcNewBitmap
  hdcNewBitmap: HDC; // Device context of the new Bitmap
  TextSize: Windows.SIZE; // For computing the length of button caption in pixels
  OldBitmap: HBITMAP; // Handle to the old selected bitmap
  NewBitmap: HBITMAP; // Handle of the new bitmap
  XDestBitmap, YDestBitmap: integer; // X,Y coordinate of destination rectangle for bitmap
  XDestText, YDestText: integer; // X,Y coordinates of destination rectangle for caption
  newWidth, newHeight: integer; // dimensions of new combined bitmap
  srcWidth, srcHeight: integer; // width of glyph to use, bitmap may have multiple glyphs
  BitmapRect: Windows.RECT;
  ButtonImageList: BUTTON_IMAGELIST;
  I: integer;
  ButtonCaptionW: widestring;
  AIndex: Integer;
  AImageRes: TScaledImageListResolution;
  AEffect: TGraphicsDrawEffect;

  procedure DrawBitmap(AState: TButtonState; UseThemes, AlphaDraw: Boolean);
  const
    DSS_HIDEPREFIX = $0200;
    StateToDetail: array[TButtonState] of TThemedButton =
    (
     { bsUp        } tbPushButtonNormal,
     { bsDisabled  } tbPushButtonDisabled,
     { bsDown      } tbPushButtonPressed,
     { bsExclusive } tbPushButtonPressed,
     { bsHot       } tbPushButtonHot
    );
  var
    TextFlags: DWord; // flags for caption (enabled or disabled)
    glyphWidth, glyphHeight: integer;
    OldBitmapHandle: HBITMAP; // Handle of the provious bitmap in hdcNewBitmap
    OldTextAlign: Integer;
    TmpDC: HDC;
    PaintBuffer: HPAINTBUFFER;
    Options: DTTOpts;
    Details: TThemedElementDetails;
    ShowAccel: Boolean;
    Color: TColor;
    PaintParams: TBP_PaintParams;
  begin
    glyphWidth := srcWidth;
    glyphHeight := srcHeight;

    if WindowsVersion >= wv2000 then
      ShowAccel := (SendMessage(BitBtnHandle, WM_QUERYUISTATE, 0, 0) and UISF_HIDEACCEL) = 0
    else
      ShowAccel := True;

    OldBitmapHandle := SelectObject(hdcNewBitmap, NewBitmap);
    if UseThemes and AlphaDraw then
    begin
      FillChar(PaintParams, SizeOf(PaintParams), 0);
      PaintParams.cbSize := SizeOf(PaintParams);
      PaintParams.dwFlags := BPPF_ERASE;
      PaintBuffer := BeginBufferedPaint(hdcNewBitmap, @BitmapRect, BPBF_COMPOSITED, @PaintParams, TmpDC);
    end
    else
    begin
      TmpDC := hdcNewBitmap;
      PaintBuffer := 0;
    end;
    OldFontHandle := SelectObject(TmpDC, BitBtn.Font.Reference.Handle);
    OldTextAlign := GetTextAlign(TmpDC);

    // clear background:
    // for alpha bitmap clear it with $00000000 else make it solid color for
    // further masking
    if PaintBuffer = 0 then
    begin
      Windows.FillRect(TmpDC, BitmapRect, GetSysColorBrush(COLOR_BTNFACE));
      Color := BitBtn.Font.Color;
      if Color = clDefault then
        Color := BitBtn.GetDefaultColor(dctFont);
      SetTextColor(TmpDC, ColorToRGB(Color));
    end;

    if AState <> bsDisabled then
    begin
      if (srcWidth <> 0) and (srcHeight <> 0) then
      begin
        TBitBtnAceess(BitBtn).FButtonGlyph.GetImageIndexAndEffect(AState, BitBtn.Font.PixelsPerInch, 1,
          AImageRes, AIndex, AEffect);
        TWin32WSCustomImageListResolution.DrawToDC(
          AImageRes.Resolution,
          AIndex, TmpDC, Rect(XDestBitmap, YDestBitmap, glyphWidth, glyphHeight),
          AImageRes.Resolution.ImageList.BkColor,
          AImageRes.Resolution.ImageList.BlendColor, AEffect,
          AImageRes.Resolution.ImageList.DrawingStyle,
          AImageRes.Resolution.ImageList.ImageType);
      end;
    end else
    begin
      // when not themed, windows wants a white background picture for disabled button image
      if not UseThemes then
        FillRect(TmpDC, BitmapRect, GetStockObject(WHITE_BRUSH));

      if (srcWidth <> 0) and (srcHeight <> 0) then
      begin
        TBitBtnAceess(BitBtn).FButtonGlyph.GetImageIndexAndEffect(AState, BitBtn.Font.PixelsPerInch, 1,
          AImageRes, AIndex, AEffect);
        if UseThemes and not AlphaDraw then
        begin
          // non-themed winapi wants white/other as background/picture-disabled colors
          // themed winapi draws bitmap-as, with transparency defined by bitbtn.brush color
          SetBkColor(TmpDC, GetSysColor(COLOR_BTNFACE));
          SetTextColor(TmpDC, GetSysColor(COLOR_BTNSHADOW));
        end
        else
        if (AEffect = gdeDisabled) and not AlphaDraw then
          AEffect := gde1Bit;

        TWin32WSCustomImageListResolution.DrawToDC(
          AImageRes.Resolution,
          AIndex, TmpDC, Rect(XDestBitmap, YDestBitmap, glyphWidth, glyphHeight),
          AImageRes.Resolution.ImageList.BkColor,
          AImageRes.Resolution.ImageList.BlendColor, AEffect,
          AImageRes.Resolution.ImageList.DrawingStyle,
          AImageRes.Resolution.ImageList.ImageType);
      end;
    end;
    if PaintBuffer = 0 then
    begin
      TextFlags := DST_PREFIXTEXT;

      if (AState = bsDisabled) then
        TextFlags := TextFlags or DSS_DISABLED;

      if not ShowAccel then
        TextFlags := TextFlags or DSS_HIDEPREFIX;

      SetBkMode(TmpDC, TRANSPARENT);
      if BitBtn.UseRightToLeftReading then
        SetTextAlign(TmpDC, OldTextAlign or TA_RTLREADING);
      ButtonCaptionW := UTF8ToUTF16(ButtonCaption);
      DrawStateW(TmpDC, 0, nil, LPARAM(ButtonCaptionW), 0, XDestText, YDestText, 0, 0, TextFlags);
    end
    else
    begin
      Details := ThemeServices.GetElementDetails(StateToDetail[AState]);
      FillChar(Options, SizeOf(Options), 0);
      Options.dwSize := SizeOf(Options);
      Options.dwFlags := DTT_COMPOSITED;
      TextFlags := DT_SINGLELINE;
      if not ShowAccel then
        TextFlags := TextFlags or DT_HIDEPREFIX;
      if AState <> bsDisabled then
      begin
        // change color to requested or it will be black
        Color := BitBtn.Font.Color;
        if Color = clDefault then
          Color := BitBtn.GetDefaultColor(dctFont);
        Options.crText := ThemeServices.ColorToRGB(Color, @Details);
        Options.dwFlags := Options.dwFlags or DTT_TEXTCOLOR;
      end;
      TWin32ThemeServices(ThemeServices).DrawTextEx(TmpDC, Details, ButtonCaption,
        Rect(XDestText, YDestText, XDestText + TextSize.cx, YDestText + TextSize.cy),
        TextFlags, @Options);
    end;
    SetTextAlign(TmpDC, OldTextAlign);
    SelectObject(TmpDC, OldFontHandle);
    if PaintBuffer <> 0 then
      EndBufferedPaint(PaintBuffer, True);
    NewBitmap := SelectObject(hdcNewBitmap, OldBitmapHandle);
  end;

var
  RGBA: PRGBAQuad;
  AlphaDraw: Boolean;
  ASpacing: Integer;
  lMargin: Integer;
begin
  // gather info about bitbtn
  BitBtnHandle := BitBtn.Handle;
  ASpacing := BitBtn.Spacing;
  if BitBtn.Margin = -1 then lMargin := 0 else lMargin := BitBtn.Margin;

  if BitBtn.CanShowGlyph(True) then
  begin
    TBitBtnAceess(BitBtn).FButtonGlyph.GetImageIndexAndEffect(Low(TButtonState), BitBtn.Font.PixelsPerInch, 1,
      AImageRes, AIndex, AEffect);
    srcWidth := AImageRes.Width;
    srcHeight := AImageRes.Height;
  end else
  begin
    srcWidth := 0;
    srcHeight := 0;
  end;
  {set spacing to LCL's default if bitbtn does not have glyph.issue #23255}
  if (srcWidth = 0) or (srcHeight = 0) then
    ASpacing := 0;
  newWidth := 0;
  newHeight := 0;
  BitBtnLayout := BidiAdjustButtonLayout(BitBtn.UseRightToLeftReading, BitBtn.Layout);
  BitBtnDC := GetDC(BitBtnHandle);
  hdcNewBitmap := CreateCompatibleDC(BitBtnDC);
  MeasureText(BitBtn, ButtonCaption, TextSize.cx, TextSize.cy);
  // calculate size of new bitmap
  case BitBtnLayout of
    blGlyphLeft, blGlyphRight:
    begin
      if ASpacing = -1 then
        newWidth := BitBtn.Width
      else
        newWidth := TextSize.cx + srcWidth + ASpacing + lMargin;
      newHeight := TextSize.cy;
      if newHeight < srcHeight then
        newHeight := srcHeight;
      YDestBitmap := (newHeight - srcHeight) div 2;
      YDestText := (newHeight - TextSize.cy) div 2;
      case BitBtnLayout of
        blGlyphLeft:
        begin
          XDestBitmap := lMargin;
          XDestText := srcWidth;
          if ASpacing = -1 then begin
            if BitBtn.Margin = -1 then begin
              XDestBitmap := (BitBtn.Width - (srcWidth + TextSize.cx)) div 3;
              XDestText := 2*XDestBitmap + srcWidth;
            end else
              inc(XDestText, (newWidth - srcWidth - TextSize.cx + lMargin) div 2);
          end else
            inc(XDestText, ASpacing + lMargin);
        end;
        blGlyphRight:
        begin
          XDestBitmap := newWidth - srcWidth - lMargin;
          XDestText := XDestBitmap - TextSize.cx;
          if ASpacing = -1 then begin
            if BitBtn.Margin = -1 then begin
              XDestText := (BitBtn.Width - (srcWidth + TextSize.cx)) div 3;
              XDestBitmap := 2 * XDestText + TextSize.cx;
            end else
              dec(XDestText, (newWidth - srcWidth - TextSize.cx - lMargin) div 2)
          end else
            dec(XDestText, ASpacing);
        end;
      end;
    end;
    blGlyphTop, blGlyphBottom:
    begin
      newWidth := TextSize.cx;
      if newWidth < srcWidth then
        newWidth := srcWidth;
      if ASpacing = -1 then
        newHeight := BitBtn.Height
      else
        newHeight := TextSize.cy + srcHeight + ASpacing + lMargin;
      XDestBitmap := (newWidth - srcWidth) shr 1;
      XDestText := (newWidth - TextSize.cx) shr 1;
      case BitBtnLayout of
        blGlyphTop:
        begin
          YDestBitmap := lMargin;
          YDestText := srcHeight;
          if ASpacing = -1 then begin
            if BitBtn.Margin = -1 then begin
              YDestBitmap := (BitBtn.Height - (srcHeight + TextSize.cy)) div 3;
              YDestText := 2*YDestBitmap + srcHeight;
            end else
              inc(YDestText, (newHeight - srcHeight - TextSize.cy + lMargin) div 2)
          end else
            inc(YDestText, ASpacing + lMargin);
        end;
        blGlyphBottom:
        begin
          YDestBitmap := newHeight - srcHeight - lMargin;
          YDestText := YDestBitmap - TextSize.cy;
          if ASpacing = -1 then begin
            if BitBtn.Margin = -1 then begin
              YDestText := (BitBtn.Height - (srcHeight + TextSize.cy)) div 3;
              YDestBitmap := 2 * YDestText + TextSize.cy;
            end else
              dec(YDestText, (newHeight - srcHeight - TextSize.cy - lMargin) div 2)
          end else
            dec(YDestText, ASpacing);
        end;
      end;
    end;
  end;

  // create new
  BitmapRect.left := 0;
  BitmapRect.top := 0;
  BitmapRect.right := newWidth;
  BitmapRect.bottom := newHeight;

  AlphaDraw := ThemeServices.ThemesEnabled and (BeginBufferedPaint <> nil);

  if (newWidth = 0) or (newHeight = 0) then
    NewBitmap := 0
  else
  if AlphaDraw then
    NewBitmap := Create32BitHBitmap(BitBtnDC, newWidth, newHeight, RGBA)
  else
    NewBitmap := CreateCompatibleBitmap(BitBtnDC, newWidth, newHeight);

  // if new api availble then use it
  if ThemeServices.ThemesAvailable and
     (Windows.SendMessage(BitBtnHandle, BCM_GETIMAGELIST, 0, LPARAM(@ButtonImageList)) <> 0) then
  begin
    // destroy previous bitmap, set new bitmap
    if ButtonImageList.himl <> 0 then
      ImageList_Destroy(ButtonImageList.himl);
    if NewBitmap <> 0 then
    begin
      if ThemeServices.ThemesEnabled then
        if AlphaDraw then
          ButtonImageList.himl := ImageList_Create(newWidth, newHeight, ILC_COLOR32, 5, 0)
        else
          ButtonImageList.himl := ImageList_Create(newWidth, newHeight, ILC_COLORDDB or ILC_MASK, 5, 0)
      else
        ButtonImageList.himl := ImageList_Create(newWidth, newHeight, ILC_COLORDDB or ILC_MASK, 1, 0);
      ButtonImageList.margin.left := 0; //5;
      ButtonImageList.margin.right := 0; //5;
      ButtonImageList.margin.top := 0; //5;
      ButtonImageList.margin.bottom := 0; //5;
      if (BitBtn.Margin = -1) then
        ButtonImageList.uAlign := BUTTON_IMAGELIST_ALIGN_CENTER
      else
        ButtonImageList.uAlign := ord(BitBtnLayout);
      // if themes are enabled then we need to fill all state bitmaps,
      // else fill only current state bitmap
      if ThemeServices.ThemesEnabled then
      begin
        for I := 1 to 6 do
        begin
          DrawBitmap(XPBitBtn_ImageIndexToState[I], True, AlphaDraw);
          if AlphaDraw then
            ImageList_Add(ButtonImageList.himl, NewBitmap, 0)
          else
            ImageList_AddMasked(ButtonImageList.himl, NewBitmap, GetSysColor(COLOR_BTNFACE));
        end;
      end
      else
      begin
        DrawBitmap(BitBtnEnabledToButtonState[IsWindowEnabled(BitBtnHandle) or (csDesigning in BitBtn.ComponentState)], True, False);
        ImageList_AddMasked(ButtonImageList.himl, NewBitmap, GetSysColor(COLOR_BTNFACE));
      end;
    end
    else
    begin
      ButtonImageList.himl := 0;
    end;
    Windows.SendMessage(BitBtnHandle, BCM_SETIMAGELIST, 0, LPARAM(@ButtonImageList));
    if NewBitmap <> 0 then
      DeleteObject(NewBitmap);
  end else
  begin
    OldBitmap := HBITMAP(Windows.SendMessage(BitBtnHandle, BM_GETIMAGE, IMAGE_BITMAP, 0));

    if NewBitmap <> 0 then
      DrawBitmap(BitBtnEnabledToButtonState[IsWindowEnabled(BitBtnHandle) or (csDesigning in BitBtn.ComponentState)], False, False);
    Windows.SendMessage(BitBtnHandle, BM_SETIMAGE, IMAGE_BITMAP, LPARAM(NewBitmap));
    if OldBitmap <> 0 then
      DeleteObject(OldBitmap);
  end;
  
  //2020-02-08 zhangch2010
  if NewBitmap <> 0 then
     BitBtn.NewBitmap:= NewBitmap;

  DeleteDC(hdcNewBitmap);
  ReleaseDC(BitBtnHandle, BitBtnDC);
  BitBtn.Invalidate;
end;

function BitBtnWndProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
    LParam: Windows.LParam): LResult; stdcall;
var
  Info: PWin32WindowInfo;
  Control: TWinControl;
  ButtonImageList: BUTTON_IMAGELIST;
  ImageList: HIMAGELIST;
  LMessage: TLMessage;
begin
  Info := GetWin32WindowInfo(Window);
  if (Info = nil) or (Info^.WinControl = nil) then
  begin
    Result := CallDefaultWindowProc(Window, Msg, WParam, LParam);
    Exit;
  end
  else
    Control := Info^.WinControl;

  case Msg of
    WM_DESTROY:
      begin
        if Assigned(ThemeServices) and ThemeServices.ThemesAvailable and
           (Windows.SendMessage(Window, BCM_GETIMAGELIST, 0, Windows.LPARAM(@ButtonImageList)) <> 0) then
        begin
          // delete and destroy button imagelist
          if ButtonImageList.himl <> 0 then
          begin
            ImageList:=ButtonImageList.himl;
            ButtonImageList.himl:=0;
            Windows.SendMessage(Window, BCM_SETIMAGELIST, 0, Windows.LPARAM(@ButtonImageList));
            ImageList_Destroy(ImageList);
          end;
        end;
        Result := WindowProc(Window, Msg, WParam, LParam);
      end;
    WM_GETFONT:
      begin
        Result := LResult(Control.Font.Reference.Handle);
      end;
    WM_UPDATEUISTATE:
      begin
        Result := WindowProc(Window, Msg, WParam, LParam);
        DrawBitBtnImage(TBitBtn(Control), TBitBtn(Control).Caption);
      end;
    WM_PAINT,
    WM_ERASEBKGND:
      begin
        if not Control.DoubleBuffered then
        begin
          LMessage.msg := Msg;
          LMessage.wParam := WParam;
          LMessage.lParam := LParam;
          LMessage.Result := 0;
          Result := DeliverMessage(Control, LMessage);
        end
        else
          Result := WindowProc(Window, Msg, WParam, LParam);
      end;
    WM_PRINTCLIENT:
      Result := CallDefaultWindowProc(Window, Msg, WParam, LParam);
    else
      Result := WindowProc(Window, Msg, WParam, LParam);
  end;
end;


class function TWin32WSBitBtn.CreateHandle(const AWinControl: TWinControl;
  const AParams: TCreateParams): HWND;
var
  Params: TCreateWindowExParams;
begin
  // general initialization of Params
  PrepareCreateWindow(AWinControl, AParams, Params);
  // customization of Params
  with Params do
  begin
    pClassName := @ButtonClsName[0];
    Flags := Flags or BS_BITMAP;
    WindowTitle := '';
    SubClassWndProc := @BitBtnWndProc;
  end;
  // create window
  FinishCreateWindow(AWinControl, Params, false);
  Result := Params.Window;
end;

class procedure TWin32WSBitBtn.GetPreferredSize(const AWinControl: TWinControl;
  var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean);
var
  BitBtn: TBitBtn absolute AWinControl;
  spacing, srcWidth, AIndex: integer;
  AImageRes: TScaledImageListResolution;
  AEffect: TGraphicsDrawEffect;
begin
  if MeasureText(AWinControl, AWinControl.Caption, PreferredWidth, PreferredHeight) then
  begin
    if BitBtn.CanShowGlyph(True) then
    begin
      TBitBtnAceess(BitBtn).FButtonGlyph.GetImageIndexAndEffect(Low(TButtonState), BitBtn.Font.PixelsPerInch, 1,
        AImageRes, AIndex, AEffect);
      srcWidth := AImageRes.Width;
      if BitBtn.Spacing = -1 then
        spacing := 8
      else
        spacing := BitBtn.Spacing;
      if BitBtn.Layout in [blGlyphLeft, blGlyphRight] then
      begin
        Inc(PreferredWidth, spacing + srcWidth);
        if AImageRes.Height > PreferredHeight then
          PreferredHeight := AImageRes.Height;
      end else begin
        Inc(PreferredHeight, spacing + AImageRes.Height);
        if srcWidth > PreferredWidth then
          PreferredWidth := srcWidth;
      end;
    end;
    Inc(PreferredWidth, 20);
    Inc(PreferredHeight, 4);
    if WithThemeSpace then
    begin
      Inc(PreferredWidth, 6);
      Inc(PreferredHeight, 6);
    end;
  end;
end;

class procedure TWin32WSBitBtn.SetBounds(const AWinControl: TWinControl;
  const ALeft, ATop, AWidth, AHeight: integer);
begin
  if not WSCheckHandleAllocated(AWinControl, 'SetBounds') then Exit;
  TWin32WSWinControl.SetBounds(AWinControl, ALeft, ATop, AWidth, AHeight);
  if TCustomBitBtn(AWinControl).Spacing = -1 then
    DrawBitBtnImage(TCustomBitBtn(AWinControl), AWinControl.Caption);
end;

class procedure TWin32WSBitBtn.SetBiDiMode(const AWinControl: TWinControl;
  UseRightToLeftAlign, UseRightToLeftReading, UseRightToLeftScrollBar: Boolean);
begin
  DrawBitBtnImage(TCustomBitBtn(AWinControl), AWinControl.Caption);
end;

class procedure TWin32WSBitBtn.SetColor(const AWinControl: TWinControl);
begin
  if not WSCheckHandleAllocated(AWinControl, 'SetColor') then Exit;
  TWin32WSWinControl.SetColor(AWinControl);
  DrawBitBtnImage(TCustomBitBtn(AWinControl), AWinControl.Caption);
end;

class procedure TWin32WSBitBtn.SetFont(const AWinControl: TWinControl;
  const AFont: TFont);
begin
  if not WSCheckHandleAllocated(AWinControl, 'SetFont') then Exit;
  TWin32WSWinControl.SetFont(AWinControl, AFont);
  DrawBitBtnImage(TCustomBitBtn(AWinControl), AWinControl.Caption);
end;

class procedure TWin32WSBitBtn.SetGlyph(const ABitBtn: TCustomBitBtn;
  const AValue: TButtonGlyph);
begin
  if not WSCheckHandleAllocated(ABitBtn, 'SetGlyph') then Exit;
  DrawBitBtnImage(ABitBtn, ABitBtn.Caption);
end;

class procedure TWin32WSBitBtn.SetLayout(const ABitBtn: TCustomBitBtn;
  const AValue: TButtonLayout);
begin
  if not WSCheckHandleAllocated(ABitBtn, 'SetLayout') then Exit;
  DrawBitBtnImage(ABitBtn, ABitBtn.Caption);
end;

class procedure TWin32WSBitBtn.SetMargin(const ABitBtn: TCustomBitBtn;
  const AValue: Integer);
begin
  if not WSCheckHandleAllocated(ABitBtn, 'SetMargin') then Exit;
  DrawBitBtnImage(ABitBtn, ABitBtn.Caption);
end;

class procedure TWin32WSBitBtn.SetSpacing(const ABitBtn: TCustomBitBtn;
  const AValue: Integer);
begin
  if not WSCheckHandleAllocated(ABitBtn, 'SetSpacing') then Exit;
  DrawBitBtnImage(ABitBtn, ABitBtn.Caption);
end;

class procedure TWin32WSBitBtn.SetText(const AWinControl: TWinControl; const AText: string);
begin
  if not WSCheckHandleAllocated(AWinControl, 'SetText') then Exit;
  //TWin32WSWinControl.SetText(AWinControl, AText);
  DrawBitBtnImage(TCustomBitBtn(AWinControl), AText);
end;

end.
win32wsbuttons.pp (25,136 bytes)

Juha Manninen

2020-02-17 19:59

developer   ~0121149

zhangch2010, if you know how to fix the problem then please create a patch:
 https://wiki.freepascal.org/Creating_A_Patch

zhangch2010

2020-02-19 01:38

reporter   ~0121162

created a patch

2020-02-18 BitButton leaks.patch (1,456 bytes)
Index: lcl/buttons.pp
===================================================================
--- lcl/buttons.pp	(版本 62643)
+++ lcl/buttons.pp	(工作副本)
@@ -204,6 +204,8 @@
     procedure LoadGlyphFromStock(idButton: Integer);
     function CanShowGlyph(const AWithShowMode: Boolean = False): Boolean;
   public
+  
+	NewBitmap: HBITMAP; // Handle of the new bitmap
     property Caption stored IsCaptionStored;
     property DefaultCaption: Boolean read FDefaultCaption write FDefaultCaption default False;
     property Glyph: TBitmap read GetGlyph write SetGlyph stored IsGlyphStored;
Index: lcl/include/bitbtn.inc
===================================================================
--- lcl/include/bitbtn.inc	(版本 62643)
+++ lcl/include/bitbtn.inc	(工作副本)
@@ -37,6 +37,11 @@
 begin
   FreeThenNil(FButtonGlyph);
   FreeAndNil(FImageChangeLink);
+  
+  if NewBitmap <>0 then begin
+    DeleteObject(NewBitmap);
+  end;
+	
   inherited Destroy;
 end;
 
Index: lcl/interfaces/win32/win32wsbuttons.pp
===================================================================
--- lcl/interfaces/win32/win32wsbuttons.pp	(版本 62643)
+++ lcl/interfaces/win32/win32wsbuttons.pp	(工作副本)
@@ -477,6 +477,9 @@
     if OldBitmap <> 0 then
       DeleteObject(OldBitmap);
   end;
+  if NewBitmap <> 0 then
+     BitBtn.NewBitmap:= NewBitmap;
+	 
   DeleteDC(hdcNewBitmap);
   ReleaseDC(BitBtnHandle, BitBtnDC);
   BitBtn.Invalidate;

Juha Manninen

2020-02-19 08:19

developer   ~0121163

The patch defines and deletes NewBitmap in common LCL code but assignes it only in Win32 widgetset code.
It does not look right. Can't it be done inside widgetset code only?

Anton Kavalenka

2020-02-20 15:07

reporter   ~0121175

Last edited: 2020-02-20 15:17

View 4 revisions

win32wsbuttons.pp:426

BitButton has associated Win32 imagelist which contains state icons.

At line 426 the Imagelist is destroyed.
ImageList_Destroy as Microsoft states just deletes ImageList object.
https://docs.microsoft.com/en-us/windows/win32/api/commctrl/nf-commctrl-imagelist_destroy

At lines 452-455 the Imagelist is filled with newly created images.


https://docs.microsoft.com/en-us/windows/win32/api/commctrl/nf-commctrl-imagelist_add
Remarks
The ImageList_Add function copies the bitmap to an internal data structure. Be sure to use the DeleteObject function to delete hbmImage and hbmMask after the function returns.

Issue History

Date Modified Username Field Change
2020-02-07 16:53 zhangch2010 New Issue
2020-02-07 16:53 zhangch2010 File Added: demo.zip
2020-02-07 16:53 zhangch2010 File Added: ok.PNG
2020-02-07 16:53 zhangch2010 File Added: NG.PNG
2020-02-07 17:09 Anton Kavalenka Note Added: 0120920
2020-02-07 17:19 Anton Kavalenka Note Edited: 0120920 View Revisions
2020-02-07 17:20 Anton Kavalenka Note Edited: 0120920 View Revisions
2020-02-07 17:24 Marco van de Voort Project FPC => Lazarus
2020-02-07 20:24 Martin Friebe Product Version 3.0.4 =>
2020-02-07 20:24 Martin Friebe LazTarget => -
2020-02-07 20:26 Martin Friebe Summary 多次打开窗体关闭后bitbtn异常 => BitButton leaks GDI objects / 多次打开窗体关闭后bitbtn异常
2020-02-07 20:26 Martin Friebe Note Added: 0120927
2020-02-07 20:26 Martin Friebe Widgetset => Win32/Win64
2020-02-07 22:36 Maxim Ganetsky Description Updated View Revisions
2020-02-07 22:36 Maxim Ganetsky Widgetset Win32/Win64 => Win32/Win64
2020-02-08 11:59 zhangch2010 File Added: pic1.PNG
2020-02-08 11:59 zhangch2010 Note Added: 0120941
2020-02-08 16:58 zhangch2010 File Added: ok-2.PNG
2020-02-08 16:58 zhangch2010 File Added: bitbtn.inc
2020-02-08 16:58 zhangch2010 File Added: buttons.pp
2020-02-08 16:58 zhangch2010 File Added: win32wsbuttons.pp
2020-02-08 16:58 zhangch2010 Note Added: 0120944
2020-02-17 19:59 Juha Manninen Note Added: 0121149
2020-02-19 01:38 zhangch2010 File Added: 2020-02-18 BitButton leaks.patch
2020-02-19 01:38 zhangch2010 Note Added: 0121162
2020-02-19 08:19 Juha Manninen Note Added: 0121163
2020-02-20 15:07 Anton Kavalenka Note Added: 0121175
2020-02-20 15:08 Anton Kavalenka Note Edited: 0121175 View Revisions
2020-02-20 15:16 Anton Kavalenka Note Edited: 0121175 View Revisions
2020-02-20 15:17 Anton Kavalenka Note Edited: 0121175 View Revisions