paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 23:58:06 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: High-DPI ImageList: reload WS image lists on resolution handle destruction (TPageControl, TListView)

Browse Source 
git-svn-id: branches/HiDPIImageList@57073 -
This commit is contained in:
ondrej 2018-01-13 12:01:07 +00:00
parent 9f890e6f52
commit 039c7ea1bf
8 changed files with 94 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
lcl/comctrls.pp
View File

@ -33,9 +33,9 @@ uses
// LazUtils
LazUTF8, LazUTF8Classes,
// LCL
LCLStrConsts, LResources, LCLIntf, LCLType, LMessages, WSLCLClasses, LCLProc,
GraphType, Graphics, ImgList, ActnList, Themes, Menus, Controls, Forms,
StdCtrls, ExtCtrls, ToolWin, Buttons;
LCLStrConsts, LResources, LCLIntf, LCLType, LMessages, WSLCLClasses,
WSReferences, LCLProc, GraphType, Graphics, ImgList, ActnList, Themes, Menus,
Controls, Forms, StdCtrls, ExtCtrls, ToolWin, Buttons;
type
THitTest = (htAbove, htBelow, htNowhere, htOnItem, htOnButton, htOnIcon,
@ -423,6 +423,9 @@ type
procedure ShowCurrentPage;
procedure UpdateAllDesignerFlags;
procedure UpdateDesignerFlags(APageIndex: integer);
procedure DoImageListDestroyResolutionHandle(Sender: TCustomImageList;
AWidth: Integer; AReferenceHandle: TLCLHandle);
procedure SetImageListAsync(Data: PtrInt);
protected
PageClass: TCustomPageClass;
function GetPageClass: TCustomPageClass; virtual;
@ -1468,6 +1471,9 @@ type
procedure CNNotify(var AMessage: TLMNotify); message CN_NOTIFY;
procedure CNDrawItem(var Message: TLMDrawListItem); message CN_DRAWITEM;
procedure InvalidateSelected;
procedure ImageResolutionHandleDestroyed(Sender: TCustomImageList;
AWidth: Integer; AReferenceHandle: TLCLHandle);
procedure SetImageListAsync(Data: PtrInt);
private
FOnCreateItemClass: TLVCreateItemClassEvent;
FOnDrawItem: TLVDrawItemEvent;

12
lcl/imglist.pp
View File

@ -66,14 +66,20 @@ type
TCustomImageList = class; //forward declaration
TDestroyResolutionHandleEvent = procedure(Sender: TCustomImageList; AWidth: Integer; AReferenceHandle: TLCLHandle) of object;
TChangeLink = class(TObject)
private
FSender: TCustomImageList;
FOnChange: TNotifyEvent;
FOnDestroyResolutionHandle: TDestroyResolutionHandleEvent;
procedure DoDestroyResolutionReference(const AWidth: Integer; AResolutionReference: TLCLHandle);
public
destructor Destroy; override;
procedure Change; virtual;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnDestroyResolutionHandle: TDestroyResolutionHandleEvent read FOnDestroyResolutionHandle write FOnDestroyResolutionHandle;
property Sender: TCustomImageList read FSender write FSender;
end;
@ -137,11 +143,10 @@ type
procedure WriteData(AStream: TStream);
procedure ReadData(AStream: TStream);
protected
property ImageList: TCustomImageList read FImageList;
function GetReferenceHandle: THandle; override;
function WSCreateReference(AParams: TCreateParams): PWSReference; override;
class procedure WSRegisterClass; override;
procedure ReferenceDestroying; override;
public
destructor Destroy; override;
public
@ -167,9 +172,11 @@ type
procedure DrawOverlay(ACanvas: TCanvas; AX, AY, AIndex: Integer; AOverlay: TOverlay; ADrawingStyle:
TDrawingStyle; AImageType: TImageType; ADrawEffect: TGraphicsDrawEffect); overload;
property ImageList: TCustomImageList read FImageList;
property Width: Integer read FWidth;
property Height: Integer read FHeight;
property Count: Integer read FCount;
property AutoCreatedInDesignTime: Boolean read FAutoCreatedInDesignTime write FAutoCreatedInDesignTime;
property Reference: TWSCustomImageListReference read GetReference;
@ -255,6 +262,7 @@ type
function GetResolutionByIndex(AIndex: Integer): TCustomImageListResolution;
function GetResolutionCount: Integer;
procedure CreateDefaultResolution;
procedure DoDestroyResolutionReference(const AWidth: Integer; AResolutionReference: TLCLHandle);
protected
function GetResolution(AImageWidth: Integer): TCustomImageListResolution;
function GetResolutionClass: TCustomImageListResolutionClass; virtual;

37
lcl/include/customlistview.inc
View File

@ -127,6 +127,7 @@ begin
begin
FImageChangeLinks[lvil] := TChangeLink.Create;
FImageChangeLinks[lvil].OnChange := @ImageChanged;
FImageChangeLinks[lvil].OnDestroyResolutionHandle := @ImageResolutionHandleDestroyed;
end;
FHoverTime := -1;
TabStop := true;
@ -536,7 +537,7 @@ begin
for lvil := Low(TListViewImageList) to High(TListViewImageList) do
begin
if FImages[lvil] <> nil
then LVC.SetImageList(Self, lvil, FImages[lvil].ResolutionForPPI[FImagesWidth[lvil], Font.PixelsPerInch]);
then LVC.SetImageList(Self, lvil, FImages[lvil].ResolutionForPPI[FImagesWidth[lvil], Font.PixelsPerInch]); // xxx
end;
LVC.SetScrollBars(Self, FScrollBars);
LVC.SetViewOrigin(Self, FViewOriginCache) ;
@ -800,8 +801,11 @@ end;
procedure TCustomListView.QueuedShowEditor(Data: PtrInt);
begin
fShowEditorQueued:=false;
ShowEditor;
if fShowEditorQueued then
begin
fShowEditorQueued:=false;
ShowEditor;
end;
end;
procedure TCustomListView.DblClick;
@ -1028,6 +1032,7 @@ destructor TCustomListView.Destroy;
var
lvil: TListViewImageList;
begin
Application.RemoveAsyncCalls(Self);
// Better destroy the wincontrol (=widget) first. So wo don't have to delete
// all items/columns and we won't get notifications for each.
FreeAndNil(FCanvas);
@ -1149,7 +1154,7 @@ end;
procedure TCustomListView.FinalizeWnd;
begin
ShowEditorQueued:=false;
FShowEditorQueued:=false;
// store origin
FViewOriginCache := TWSCustomListViewClass(WidgetSetClass).GetViewOrigin(Self);
if not OwnerData then
@ -1583,6 +1588,11 @@ begin
SetImageListWS(lvil);
end;
procedure TCustomListView.SetImageListAsync(Data: PtrInt);
begin
SetImageListWS(TListViewImageList(Data));
end;
procedure TCustomListView.SetImageListWidth(const ALvilOrd: Integer;
const AValue: Integer);
var
@ -1672,10 +1682,8 @@ procedure TCustomListView.SetShowEditorQueued(AValue: boolean);
begin
if FShowEditorQueued=AValue then Exit;
FShowEditorQueued:=AValue;
if ShowEditorQueued then
Application.QueueAsyncCall(@QueuedShowEditor,0)
else
Application.RemoveAsyncCalls(Self);
if FShowEditorQueued then
Application.QueueAsyncCall(@QueuedShowEditor,0);
end;
procedure TCustomListView.SetOwnerData(const AValue: Boolean);
@ -1725,6 +1733,19 @@ begin
// end;
end;
procedure TCustomListView.ImageResolutionHandleDestroyed(
Sender: TCustomImageList; AWidth: Integer; AReferenceHandle: TLCLHandle);
var
lvil: TListViewImageList;
begin
for lvil in TListViewImageList do
if Sender = FImages[lvil] then
begin
TWSCustomListViewClass(WidgetSetClass).SetImageList(Self, lvil, nil);
Application.QueueAsyncCall(@SetImageListAsync, Ord(lvil));
end;
end;
procedure TCustomListView.Loaded;
begin
// create interface columns if needed

15
lcl/include/customnotebook.inc
View File

@ -270,6 +270,7 @@ begin
FImageListChangeLink := TChangeLink.Create;
FImageListChangeLink.OnChange := @DoImageListChange;
FImageListChangeLink.OnDestroyResolutionHandle := @DoImageListDestroyResolutionHandle;
FPageIndex := -1;
@ -353,6 +354,7 @@ begin
FImageListChangeLink.Free;
Pages.Clear;
FreeAndNil(FAccess);
Application.RemoveAsyncCalls(Self);
inherited Destroy;
end;
@ -527,6 +529,11 @@ begin
PageIndex := IndexOf(AValue); // -1 for unpaged
end;
procedure TCustomTabControl.SetImageListAsync(Data: PtrInt);
begin
DoImageListChange(Self);
end;
procedure TCustomTabControl.SetImages(const AValue: TCustomImageList);
begin
if FImages = AValue then Exit;
@ -1184,7 +1191,13 @@ end;
procedure TCustomTabControl.DoImageListChange(Sender: TObject);
begin
if HandleAllocated then
TWSCustomTabControlClass(WidgetSetClass).SetImageList(Self, Images);
TWSCustomTabControlClass(WidgetSetClass).SetImageList(Self, Images.ResolutionForPPI[ImagesWidth, Font.PixelsPerInch]);
end;
procedure TCustomTabControl.DoImageListDestroyResolutionHandle(
Sender: TCustomImageList; AWidth: Integer; AReferenceHandle: TLCLHandle);
begin
TWSCustomTabControlClass(WidgetSetClass).SetImageList(Self, nil);
Application.QueueAsyncCall(@SetImageListAsync, 0);
end;

26
lcl/include/imglist.inc
View File

@ -766,6 +766,13 @@ begin
end;
end;
procedure TCustomImageListResolution.ReferenceDestroying;
begin
inherited ReferenceDestroying;
FImageList.DoDestroyResolutionReference(FWidth, Reference._Handle);
end;
procedure TCustomImageListResolution.StretchDraw(Canvas: TCanvas;
Index: Integer; ARect: TRect; Enabled: Boolean);
var
@ -1319,6 +1326,18 @@ begin
FreeThenNil(FChangeLinkList);
end;
procedure TCustomImageList.DoDestroyResolutionReference(const AWidth: Integer;
AResolutionReference: TLCLHandle);
var
I: Integer;
begin
if FChangeLinkList=nil then
Exit;
for I := 0 to FChangeLinkList.Count-1 do
if TChangeLink(FChangeLinkList[I]).Sender = Self then
TChangeLink(FChangeLinkList[I]).DoDestroyResolutionReference(AWidth, AResolutionReference);
end;
{------------------------------------------------------------------------------
Method: TCustomImageList.Draw
Params: Canvas: the canvas to draw on
@ -2279,4 +2298,11 @@ begin
inherited Destroy;
end;
procedure TChangeLink.DoDestroyResolutionReference(const AWidth: Integer;
AResolutionReference: TLCLHandle);
begin
if Assigned(FOnDestroyResolutionHandle) then
FOnDestroyResolutionHandle(FSender, AWidth, AResolutionReference);
end;
// included by imglist.pp

4
lcl/interfaces/win32/win32pagecontrol.inc
View File

@ -644,7 +644,7 @@ begin
end;
class procedure TWin32WSCustomTabControl.SetImageList(
const ATabControl: TCustomTabControl; const AImageList: TCustomImageList);
const ATabControl: TCustomTabControl; const AImageList: TCustomImageListResolution);
begin
if ATabControl is TTabControl then
exit;
@ -653,7 +653,7 @@ begin
Exit;
if AImageList <> nil then
SendMessage(ATabControl.Handle, TCM_SETIMAGELIST, 0, AImageList.ReferenceForPPI[ATabControl.ImagesWidth, ATabControl.Font.PixelsPerInch]._Handle)
SendMessage(ATabControl.Handle, TCM_SETIMAGELIST, 0, AImageList.Reference._Handle)
else
SendMessage(ATabControl.Handle, TCM_SETIMAGELIST, 0, 0);
// if you set big images like 32x32 then tabs will be big too => you need to

4
lcl/interfaces/win32/win32wscomctrls.pp
View File

@ -69,10 +69,10 @@ type
class function GetNotebookMinTabWidth(const AWinControl: TWinControl): integer; override;
class function GetTabIndexAtPos(const ATabControl: TCustomTabControl; const AClientPos: TPoint): integer; override;
class function GetTabRect(const ATabControl: TCustomTabControl; const AIndex: Integer): TRect; override;
class function GetCapabilities: TCTabControlCapabilities;override;
class function GetCapabilities: TCTabControlCapabilities; override;
class function GetDesignInteractive(const AWinControl: TWinControl; AClientPos: TPoint): Boolean; override;
class procedure SetTabSize(const ATabControl: TCustomTabControl; const ATabWidth, ATabHeight: integer); override;
class procedure SetImageList(const ATabControl: TCustomTabControl; const AImageList: TCustomImageList); override;
class procedure SetImageList(const ATabControl: TCustomTabControl; const AImageList: TCustomImageListResolution); override;
class procedure SetPageIndex(const ATabControl: TCustomTabControl; const AIndex: integer); override;
class procedure SetTabPosition(const ATabControl: TCustomTabControl; const ATabPosition: TTabPosition); override;
class procedure ShowTabs(const ATabControl: TCustomTabControl; AShowTabs: boolean); override;

4
lcl/widgetset/wscomctrls.pp
View File

@ -66,7 +66,7 @@ type
class function GetTabRect(const ATabControl: TCustomTabControl; const AIndex: Integer): TRect; virtual;
class function GetCapabilities: TCTabControlCapabilities; virtual;
class procedure SetTabSize(const ATabControl: TCustomTabControl; const ATabWidth, ATabHeight: integer); virtual;
class procedure SetImageList(const ATabControl: TCustomTabControl; const AImageList: TCustomImageList); virtual;
class procedure SetImageList(const ATabControl: TCustomTabControl; const AImageList: TCustomImageListResolution); virtual;
class procedure SetPageIndex(const ATabControl: TCustomTabControl; const AIndex: integer); virtual;
class procedure SetTabCaption(const ATabControl: TCustomTabControl; const AChild: TCustomPage; const AText: string); virtual;
class procedure SetTabPosition(const ATabControl: TCustomTabControl; const ATabPosition: TTabPosition); virtual;
@ -367,7 +367,7 @@ begin
end;
class procedure TWSCustomTabControl.SetImageList(
const ATabControl: TCustomTabControl; const AImageList: TCustomImageList);
const ATabControl: TCustomTabControl; const AImageList: TCustomImageListResolution);
begin
end;