View Issue Details

IDProjectCategoryView StatusLast Update
0036678LazarusOtherpublic2020-05-27 00:01
Reporterzhangch2010 Assigned ToBart Broersma  
PrioritynormalSeverityminorReproducibilityalways
Status resolvedResolutionreopened 
OSWindows 
Target Version2.2Fixed in Version2.2 
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 Revisionr62947, r63227
LazTarget-
WidgetsetWin32/Win64
Attached Files

Relationships

related to 0037105 closedBart Broersma Win32: TBitBtn does not show Caption and Glyph without using manifest in resources 

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.

Anton Kavalenka

2020-03-12 14:50

reporter   ~0121572

Last edited: 2020-03-13 05:53

View 4 revisions

I changed slightly the logic and the GDI handle count flips between 43 and 47
Currently the title counter shows ~ 120 - handle count remains in 43-47 range.

win32wsbuttons.diff (743 bytes)   
Index: win32wsbuttons.pp
===================================================================
--- win32wsbuttons.pp	(revision 62739)
+++ win32wsbuttons.pp	(working copy)
@@ -466,8 +466,7 @@
       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));
@@ -477,7 +476,10 @@
     if OldBitmap <> 0 then
       DeleteObject(OldBitmap);
   end;
+
   DeleteDC(hdcNewBitmap);
+  if NewBitmap <> 0 then
+      DeleteObject(NewBitmap);
   ReleaseDC(BitBtnHandle, BitBtnDC);
   BitBtn.Invalidate;
 end;
win32wsbuttons.diff (743 bytes)   

Anton Kavalenka

2020-03-19 11:28

reporter   ~0121648

Ping @zhangch2010, @Juha Manninen, if my patch works?

Juha Manninen

2020-04-11 18:31

developer   ~0122080

Applied, thanks.

Juha Manninen

2020-05-24 14:42

developer   ~0123032

This caused a regression and must be reopened.
I hope it can be fixed without reverting the commit. I cannot test with Windows right now.

Bart Broersma

2020-05-24 15:39

developer   ~0123035

I have a test application that creates, changes ButtonKind and destroys a TBitButton at runtime in a OnTimer event.
I can have it create a TBitButton and change it's kind (which changes it glyph) > 2000 times without any error.

Bart Broersma

2020-05-24 15:51

developer   ~0123036

Last edited: 2020-05-24 16:01

View 2 revisions

There's also another strange thing about the patch: the demo example does not have any glyph assigned to the TBitButton, yet the patch is about releasing a Windows.Bitmap?

Bart Broersma

2020-05-24 16:47

developer   ~0123038

Last edited: 2020-05-24 17:00

View 2 revisions

Set most BitBtn's kind to bkOK
Tested with themes disabled (unpatched Lazarus)
Got:
TestCount = 345
GetBitmapOrder - GetDIBits OrgPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits TstPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits OrgPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits TstPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits OrgPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits TstPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits OrgPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits TstPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits OrgPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits TstPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits OrgPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits TstPixel failed: De bewerking is voltooid.
GetBitmapOrder - GetDIBits Getinfo failed: De parameter is onjuist. (SysError 6)
GetBitmapOrder - GetDIBits Getinfo failed: De parameter is onjuist.
GetBitmapOrder - GetDIBits Getinfo failed: De parameter is onjuist.
GetBitmapOrder - GetDIBits Getinfo failed: De parameter is onjuist.
GetBitmapOrder - GetDIBits Getinfo failed: De parameter is onjuist.
GetBitmapOrder - GetDIBits Getinfo failed: De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist. (SysError 87)
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.
WARNING: TLazIntfImage.ChooseRawBitsProc Unsupported BitsPerPixel=0
Windows.CreateDIBSection returns 0. Reason = De ingang is ongeldig. (SysError 6)
Windows.CreateDIBSection returns 0. Reason = De parameter is onjuist.

Captions and Glyphs are still drawn up to that point.

With ThemeServices enabled, there seems to be no problem.

Bart Broersma

2020-05-24 23:02

developer   ~0123050

Added simplified demo (gdileak.zip).
gdileak.zip (3,016 bytes)

Bart Broersma

2020-05-25 22:50

developer   ~0123065

It looks like you can only do a DeleteObject(NewBitmap) (in the affected code branch) when you destroy the button, since without it there will be no text or glyph on the button.
This cannot be done in WS code AFAICS.
B.t.w.: this bug must have been around for at least 14 years.

Anton Kavalenka

2020-05-26 17:18

reporter   ~0123076

another approach
win32wsbuttons-2.diff (1,462 bytes)   
Index: win32wsbuttons.pp
===================================================================
--- win32wsbuttons.pp	(revision 63222)
+++ win32wsbuttons.pp	(working copy)
@@ -460,6 +460,8 @@
         DrawBitmap(BitBtnEnabledToButtonState[IsWindowEnabled(BitBtnHandle) or (csDesigning in BitBtn.ComponentState)], True, False);
         ImageList_AddMasked(ButtonImageList.himl, NewBitmap, GetSysColor(COLOR_BTNFACE));
       end;
+      if NewBitmap <> 0 then
+        DeleteObject(NewBitmap);
     end
     else
     begin
@@ -476,8 +478,8 @@
       DeleteObject(OldBitmap);
   end;
   DeleteDC(hdcNewBitmap);
-  if NewBitmap <> 0 then
-      DeleteObject(NewBitmap);
+ { if NewBitmap <> 0 then
+      DeleteObject(NewBitmap);}
   ReleaseDC(BitBtnHandle, BitBtnDC);
   BitBtn.Invalidate;
 end;
@@ -489,6 +491,7 @@
   Control: TWinControl;
   ButtonImageList: BUTTON_IMAGELIST;
   ImageList: HIMAGELIST;
+  OldBitmap: HBITMAP;
   LMessage: TLMessage;
 begin
   Info := GetWin32WindowInfo(Window);
@@ -514,6 +517,11 @@
             Windows.SendMessage(Window, BCM_SETIMAGELIST, 0, Windows.LPARAM(@ButtonImageList));
             ImageList_Destroy(ImageList);
           end;
+        end else
+        begin
+          OldBitmap := HBITMAP(Windows.SendMessage(Window, BM_GETIMAGE, IMAGE_BITMAP, 0));
+          if OldBitmap <> 0 then
+            DeleteObject(OldBitmap);
         end;
         Result := WindowProc(Window, Msg, WParam, LParam);
       end;
win32wsbuttons-2.diff (1,462 bytes)   

Juha Manninen

2020-05-26 22:31

developer   ~0123080

Bart, I assign this to you. Please test the patch and apply if OK.
I cannot test with Windows now.
Me applying so many patches is a problem. I do it because nobody else does. The patches would often be ignored for a long time.
I am asking now that developers with Windows would test and apply Windows specific patches.

Bart Broersma

2020-05-26 23:52

developer   ~0123082

I ran my gdileak sample app with the second patch applied and let it cycle for > 1000 times (in effect creating and destroying over 100 thousand bitbuttons) and did this unthemened and themed. I did not encounter any crashes.
(As a side note: the unthemed version was > 10 times faster than the themed version).

Bart Broersma

2020-05-26 23:57

developer   ~0123084

@Anton: applied your second patch. Thanks.
Please test and close if OK.

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
2020-03-12 14:50 Anton Kavalenka File Added: win32wsbuttons.diff
2020-03-12 14:50 Anton Kavalenka Note Added: 0121572
2020-03-12 14:50 Anton Kavalenka Note Edited: 0121572 View Revisions
2020-03-13 05:53 Anton Kavalenka Note Edited: 0121572 View Revisions
2020-03-13 05:53 Anton Kavalenka Note Edited: 0121572 View Revisions
2020-03-19 11:28 Anton Kavalenka Note Added: 0121648
2020-04-11 17:06 Juha Manninen Assigned To => Juha Manninen
2020-04-11 17:06 Juha Manninen Status new => assigned
2020-04-11 18:31 Juha Manninen Status assigned => resolved
2020-04-11 18:31 Juha Manninen Resolution open => fixed
2020-04-11 18:31 Juha Manninen Fixed in Revision => r62947
2020-04-11 18:31 Juha Manninen Widgetset Win32/Win64 => Win32/Win64
2020-04-11 18:31 Juha Manninen Note Added: 0122080
2020-05-24 14:37 Juha Manninen Relationship added related to 0037105
2020-05-24 14:42 Juha Manninen Status resolved => assigned
2020-05-24 14:42 Juha Manninen Resolution fixed => reopened
2020-05-24 14:42 Juha Manninen Note Added: 0123032
2020-05-24 15:39 Bart Broersma Note Added: 0123035
2020-05-24 15:51 Bart Broersma Note Added: 0123036
2020-05-24 16:01 Bart Broersma Note Edited: 0123036 View Revisions
2020-05-24 16:47 Bart Broersma Note Added: 0123038
2020-05-24 17:00 Bart Broersma Note Edited: 0123038 View Revisions
2020-05-24 23:02 Bart Broersma Note Added: 0123050
2020-05-24 23:02 Bart Broersma File Added: gdileak.zip
2020-05-25 22:50 Bart Broersma Note Added: 0123065
2020-05-26 17:18 Anton Kavalenka Note Added: 0123076
2020-05-26 17:18 Anton Kavalenka File Added: win32wsbuttons-2.diff
2020-05-26 22:26 Juha Manninen Assigned To Juha Manninen => Bart Broersma
2020-05-26 22:31 Juha Manninen Note Added: 0123080
2020-05-26 23:52 Bart Broersma Note Added: 0123082
2020-05-26 23:57 Bart Broersma Status assigned => resolved
2020-05-26 23:57 Bart Broersma Fixed in Revision r62947 => r62947, r63227
2020-05-26 23:57 Bart Broersma Widgetset Win32/Win64 => Win32/Win64
2020-05-26 23:57 Bart Broersma Note Added: 0123084
2020-05-27 00:00 Bart Broersma OS => Windows
2020-05-27 00:00 Bart Broersma Fixed in Version => 2.2
2020-05-27 00:00 Bart Broersma Target Version => 2.2
2020-05-27 00:00 Bart Broersma Widgetset Win32/Win64 => Win32/Win64