paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-16 10:00:37 +01:00
Code Issues Packages Projects Releases Wiki Activity

LCL: task dialog: high-DPI support

Browse Source
This commit is contained in:
Ondrej Pokorny 2022-09-28 16:25:06 +02:00
parent a3b65673ed
commit 49647626a5
1 changed files with 158 additions and 301 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

213
lcl/lcltaskdialog.pas
View File

@ -127,12 +127,12 @@ interface
uses uses
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
Windows, Windows, ctypes,
{$ENDIF} {$ENDIF}
Classes, SysUtils, Classes, SysUtils,
LazUTF8, LazUTF8,
LCLType, LCLStrConsts, LCLIntf, InterfaceBase, LCLType, LCLStrConsts, LCLIntf, InterfaceBase, ImgList,
LResources, Menus, Graphics, Forms, Controls, StdCtrls, ExtCtrls, Buttons; LResources, Menus, Graphics, Forms, Controls, StdCtrls, ExtCtrls, Buttons, DialogRes;
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
var var
@ -415,9 +415,7 @@ function DefaultFont: TFont;
implementation implementation
uses Function LoadIconWithScaleDown( hinst:HINST; pszName:LPCWStr;cx:cint;cy:cint;var phico: HICON ):HRESULT; stdcall; external 'comctl32.dll' name 'LoadIconWithScaleDown';
Dialogs,
ImgList;
var var
LDefaultFont: TFont; LDefaultFont: TFont;
@ -458,7 +456,6 @@ begin
cbCancel: result := @rsMbCancel; cbCancel: result := @rsMbCancel;
cbRetry: result := @rsMbRetry; cbRetry: result := @rsMbRetry;
cbClose: result := @rsMbClose; cbClose: result := @rsMbClose;
else result := nil;
end; end;
end; end;
@ -495,37 +492,16 @@ end;
const const
LAZ_ICONS: array[TTaskDialogIcon] of string = ( LCL_IMAGES: array[TTaskDialogIcon] of Integer = (
'', 'dialog_warning', 'dialog_confirmation', 'dialog_error', 'dialog_information', '', 'dialog_shield'); 0, idDialogWarning, idDialogConfirm, idDialogError, idDialogInfo, 0, idDialogShield);
LAZ_FOOTERICONS: array[TTaskDialogFooterIcon] of string = ( LCL_FOOTERIMAGES: array[TTaskDialogFooterIcon] of Integer = (
'', 'dialog_warning', 'dialog_confirmation', 'dialog_error', 'dialog_information', 'dialog_shield'); 0, idDialogWarning, idDialogConfirm, idDialogError, idDialogInfo, idDialogShield);
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
const const
{$EXTERNALSYM IDI_HAND}
IDI_HAND = MakeIntResource(32513);
{$EXTERNALSYM IDI_QUESTION}
IDI_QUESTION = MakeIntResource(32514);
{$EXTERNALSYM IDI_EXCLAMATION}
IDI_EXCLAMATION = MakeIntResource(32515);
{$EXTERNALSYM IDI_ASTERISK}
IDI_ASTERISK = MakeIntResource(32516);
{$EXTERNALSYM IDI_WINLOGO}
IDI_WINLOGO = MakeIntResource(32517);
{$EXTERNALSYM IDI_WARNING}
IDI_WARNING = IDI_EXCLAMATION;
{$EXTERNALSYM IDI_ERROR}
IDI_ERROR = IDI_HAND;
{$EXTERNALSYM IDI_INFORMATION}
IDI_INFORMATION = IDI_ASTERISK;
TD_ICONS: array[TTaskDialogIcon] of integer = ( TD_ICONS: array[TTaskDialogIcon] of integer = (
0, 84, 99, 98, 81, 0, 78); 0, 84, 99, 98, 81, 0, 78);
TD_FOOTERICONS: array[TTaskDialogFooterIcon] of integer = ( TD_FOOTERICONS: array[TTaskDialogFooterIcon] of integer = (
0, 84, 99, 98, 65533, 65532); 0, 84, 99, 98, 65533, 65532);
WIN_ICONS: array[TTaskDialogIcon] of PChar = (
nil, IDI_WARNING, IDI_QUESTION, IDI_ERROR, IDI_INFORMATION, nil, nil);
WIN_FOOTERICONS: array[TTaskDialogFooterIcon] of PChar = (
nil, IDI_WARNING, IDI_QUESTION, IDI_ERROR, IDI_INFORMATION, nil);
{$ENDIF MSWINDOWS} {$ENDIF MSWINDOWS}
function IconMessage(Icon: TTaskDialogIcon): string; function IconMessage(Icon: TTaskDialogIcon): string;
@ -654,7 +630,8 @@ begin
end; end;
end; end;
var aHint: string; var
aHint: string;
function NoCR(const aText: string): string; function NoCR(const aText: string): string;
var i: integer; var i: integer;
@ -673,7 +650,8 @@ var RU: array of Ws;
RUCount: integer; RUCount: integer;
But: array of TTASKDIALOG_BUTTON; But: array of TTASKDIALOG_BUTTON;
procedure AddRU(Text: string; var n: integer; firstID: integer); procedure AddRU(Text: string; var n: integer; firstID: integer);
var P: PChar; var
P: PChar;
begin begin
if Text='' then if Text='' then
exit; exit;
@ -694,18 +672,16 @@ begin
end; end;
end; end;
{$ENDIF} {$ENDIF}
var var
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
Config: TTASKDIALOGCONFIG; Config: TTASKDIALOGCONFIG;
{$ENDIF} {$ENDIF}
Pic: TPortableNetworkGraphic;
Ico: TIcon;
Bmp: TBitmap;
i, X, Y, XB, IconBorder, FontHeight: integer; i, X, Y, XB, IconBorder, FontHeight: integer;
Par: TWinControl; Par: TWinControl;
Panel: TPanel; Panel: TPanel;
CurrTabOrder: TTabOrder; CurrTabOrder: TTabOrder;
Image: TImage; Image: TImageListImage;
List: TStrings; List: TStrings;
B: TCommonButton; B: TCommonButton;
CommandLink: TBitBtn; CommandLink: TBitBtn;
@ -717,7 +693,6 @@ var R: TRect;
begin begin
result := TLabel.Create(Dialog.Form); result := TLabel.Create(Dialog.Form);
result.Parent := Par; result.Parent := Par;
result.Font.PixelsPerInch := 96;
result.WordWrap := true; result.WordWrap := true;
if BigFont then begin if BigFont then begin
if aEmulateClassicStyle then begin if aEmulateClassicStyle then begin
@ -743,7 +718,8 @@ begin
end; end;
procedure AddBevel; procedure AddBevel;
var BX: integer; var
BX: integer;
begin begin
with TBevel.Create(Dialog.Form) do begin with TBevel.Create(Dialog.Form) do begin
Parent := Par; Parent := Par;
@ -756,7 +732,8 @@ begin
end; end;
function AddButton(const s: string; ModalResult: integer): TButton; function AddButton(const s: string; ModalResult: integer): TButton;
var WB: integer; var
WB: integer;
begin begin
WB := Dialog.Form.Canvas.TextWidth(s)+52; WB := Dialog.Form.Canvas.TextWidth(s)+52;
dec(XB,WB); dec(XB,WB);
@ -766,7 +743,6 @@ begin
end; end;
result := TButton.Create(Dialog.Form); result := TButton.Create(Dialog.Form);
result.Parent := Par; result.Parent := Par;
result.Font.PixelsPerInch := 96;
if aEmulateClassicStyle then if aEmulateClassicStyle then
result.SetBounds(XB,Y,WB-10,22) result.SetBounds(XB,Y,WB-10,22)
else else
@ -787,49 +763,8 @@ begin
Dialog.Form.ActiveControl := result; Dialog.Form.ActiveControl := result;
end; end;
procedure AddImages(AImgList: TCustomImageList; AResName: String);
var var
img100, img150, img200: TCustomBitmap;
begin
img100 := TPortableNetworkGraphic.Create;
img150 := TPortableNetworkGraphic.Create;
img200 := TPortableNetworkGraphic.Create;
try
img100.LoadFromResourceName(HInstance, AResName);
img150.LoadFromResourceName(HInstance, AResName + '_150');
img200.LoadFromResourceName(HInstance, AResName + '_200');
AImgList.AddMultipleResolutions([img100, img150, img200]);
finally
img100.Free;
img150.Free;
img200.Free;
end;
end;
var
imgList: TLCLGlyphs;
procedure PrepareImages;
var
di: TTaskDialogIcon;
begin
imgList := TLCLGlyphs.Create(Dialog.Form);
imgList.MissingResources := gmrOneMustExist;
imgList.Scaled := true;
imgList.Width := 32;
imgList.Height := 32;
imgList.RegisterResolutions([16, 24, 32, 48, 64]);
for di in TTaskDialogIcon do
if LAZ_ICONS[di] <> '' then
AddImages(imgList, LAZ_ICONS[di]);
// Since footer icons use the same image resources we do not add them again.
end;
var
IconHandle: HICON;
ARadioOffset: integer; ARadioOffset: integer;
imgIndex: Integer;
imgRes: TScaledImageListResolution;
begin begin
if (byte(aCommonButtons)=0) and (Buttons='') then begin if (byte(aCommonButtons)=0) and (Buttons='') then begin
aCommonButtons := [cbOk]; aCommonButtons := [cbOk];
@ -896,7 +831,7 @@ begin
Dialog.Form.Owner := @Self; Dialog.Form.Owner := @Self;
// initialize form properties // initialize form properties
Dialog.Form.PixelsPerInch := 96; // for scaling later Dialog.Form.PixelsPerInch := 96; // we are using 96 PPI in the code, scale it automatically at ShowModal
Dialog.Form.Font.PixelsPerInch := 96; Dialog.Form.Font.PixelsPerInch := 96;
Dialog.Form.BorderStyle := bsDialog; Dialog.Form.BorderStyle := bsDialog;
if tdfAllowDialogCancellation in aFlags then if tdfAllowDialogCancellation in aFlags then
@ -922,10 +857,6 @@ begin
Dialog.Form.ClientWidth := aWidth; Dialog.Form.ClientWidth := aWidth;
Dialog.Form.Height := 200; Dialog.Form.Height := 200;
Dialog.Form.Caption := Title; Dialog.Form.Caption := Title;
// Prepare image list
PrepareImages;
// create a white panel for the main dialog part // create a white panel for the main dialog part
Panel := TPanel.Create(Dialog.Form); Panel := TPanel.Create(Dialog.Form);
Panel.Parent := Dialog.Form; Panel.Parent := Dialog.Form;
@ -943,35 +874,13 @@ begin
else else
IconBorder := 24; IconBorder := 24;
if (LAZ_ICONS[aDialogIcon]<>'') {$IFDEF MSWINDOWS}or if (LCL_IMAGES[aDialogIcon]<>0) then
((WidgetSet.GetLCLCapability(lcNativeTaskDialog) = LCL_CAPABILITY_YES) and (WIN_ICONS[aDialogIcon]<>nil)){$ENDIF} then
begin begin
Image := TImage.Create(Dialog.Form); Image := TImageListImage.Create(Dialog.Form);
Image.Parent := Par; Image.Parent := Par;
{$IFDEF MSWINDOWS} Image.Images := GetDialogImages;
if (WidgetSet.GetLCLCapability(lcNativeTaskDialog) = LCL_CAPABILITY_YES) and Image.ImageIndex := GetDialogImages.DialogIndexes[LCL_IMAGES[aDialogIcon]];
(WIN_ICONS[aDialogIcon]<>nil) then Image.SetBounds(IconBorder,IconBorder, 32, 32);
IconHandle := LoadIcon(0,WIN_ICONS[aDialogIcon])
else
IconHandle := 0;
{$ELSE}
IconHandle := 0;
{$ENDIF}
if IconHandle<>0 then
Image.Picture.Icon.Handle := IconHandle
else if LAZ_ICONS[aDialogIcon]<>'' then
begin
imgRes := imgList.ResolutionForPPI[32, Screen.PixelsPerInch, Dialog.Form.GetCanvasScaleFactor];
imgIndex := imgList.GetImageIndex(LAZ_ICONS[aDialogIcon]);
Pic := TPortableNetworkGraphic.Create;
try
imgRes.GetBitmap(imgIndex, Pic);
Image.Picture.Assign(Pic);
finally
Pic.Free;
end;
end;
Image.SetBounds(IconBorder,IconBorder,Image.Picture.Icon.Width,Image.Picture.Icon.Height);
X := Image.Width+IconBorder*2; X := Image.Width+IconBorder*2;
Y := Image.Top; Y := Image.Top;
if aEmulateClassicStyle then if aEmulateClassicStyle then
@ -1011,6 +920,7 @@ begin
Rad[i] := TRadioButton.Create(Dialog.Form); Rad[i] := TRadioButton.Create(Dialog.Form);
with Rad[i] do begin with Rad[i] do begin
Parent := Par; Parent := Par;
AutoSize := False;
SetBounds(X+16,Y,aWidth-32-X, (6-FontHeight) + ARadioOffset); SetBounds(X+16,Y,aWidth-32-X, (6-FontHeight) + ARadioOffset);
Caption := NoCR(Strings[i]); Caption := NoCR(Strings[i]);
if aHint<>'' then begin if aHint<>'' then begin
@ -1065,8 +975,8 @@ begin
end; end;
if not (tdfUseCommandLinksNoIcon in aFlags) then if not (tdfUseCommandLinksNoIcon in aFlags) then
begin begin
Images := imgList; Images := LCLGlyphs;
ImageIndex := imgList.GetImageIndex('btn_arrowright'); ImageIndex := LCLGlyphs.GetImageIndex('btn_arrowright');
end; end;
end; end;
end; end;
@ -1158,62 +1068,15 @@ begin
AddBevel AddBevel
else else
inc(Y,16); inc(Y,16);
if (LAZ_FOOTERICONS[aFooterIcon]<>'') {$IFDEF MSWINDOWS}or ((WidgetSet.GetLCLCapability(lcNativeTaskDialog) = LCL_CAPABILITY_YES) and (WIN_FOOTERICONS[aFooterIcon]<>nil)){$ENDIF} then if (LCL_FOOTERIMAGES[aFooterIcon]<>0) then
begin begin
Image := TImage.Create(Dialog.Form); Image := TImageListImage.Create(Dialog.Form);
Image.Parent := Par; Image.Parent := Par;
Pic := nil; Image.Images := GetDialogImages;
Ico := nil; Image.ImageWidth := 16;
Bmp := TBitmap.Create; Image.ImageIndex := GetDialogImages.DialogIndexes[LCL_FOOTERIMAGES[aFooterIcon]];
try Image.SetBounds(24,Y,16,16);
Bmp.Transparent := true; X := 40+Image.Width;
{$IFDEF MSWINDOWS}
if (WIN_FOOTERICONS[aFooterIcon]<>nil) and (WidgetSet.GetLCLCapability(lcNativeTaskDialog) = LCL_CAPABILITY_YES) then
begin
IconHandle := LoadIcon(0,WIN_FOOTERICONS[aFooterIcon]);
if IconHandle<>0 then
begin
Ico := TIcon.Create;
Ico.Handle := IconHandle;
Bmp.Width := Ico.Width shr 1;
Bmp.Height := Ico.Height shr 1;
end;
end;
{$ENDIF}
if (Ico=nil) and (LAZ_FOOTERICONS[aFooterIcon]<>'') then
begin
Pic := TPortableNetworkGraphic.Create;
imgIndex := imgList.GetImageIndex(LAZ_FOOTERICONS[aFooterIcon]);
imgRes := imgList.ResolutionForPPI[16, Screen.PixelsPerInch, Dialog.Form.GetCanvasScaleFactor];
imgRes.GetBitmap(imgIndex, Pic);
Bmp.Width := Pic.Width;
Bmp.Height := Pic.Height;
end;
if (Ico<>nil) or (Pic<>nil) then
begin
Bmp.Canvas.Brush.Color := Dialog.Form.Color;
if Bmp.Canvas.Brush.Color = clDefault then
Bmp.Canvas.Brush.Color := clBtnFace;
Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
if Pic<>nil then
Bmp.Canvas.StretchDraw(Rect(0, 0, Bmp.Width, Bmp.Height), Pic)
else
begin
{$IFDEF MSWINDOWS}
if (WidgetSet.GetLCLCapability(lcNativeTaskDialog) = LCL_CAPABILITY_YES) then
DrawIconEx(Bmp.Canvas.Handle,0,0,Ico.Handle,Bmp.Width,Bmp.Height,0,
Bmp.Canvas.Brush.{%H-}Handle,DI_NORMAL);
{$ENDIF}
end;
Image.Picture.Bitmap := Bmp;
Image.SetBounds(24,Y,Bmp.Width,Bmp.Height);
X := 40+Bmp.Width;
end;
finally
Bmp.Free;
Pic.Free;
Ico.Free;
end;
end else end else
begin begin
X := 24; X := 24;
@ -1236,13 +1099,7 @@ begin
if Assigned(Dialog.Form.PopupParent) then if Assigned(Dialog.Form.PopupParent) then
Dialog.Form.PopupMode := pmExplicit; Dialog.Form.PopupMode := pmExplicit;
// show the dialog - it will scale automatically in ShowModal
// Scale the dialog
// Dialog.Form.AutoAdjustLayout(lapAutoAdjustForDPI, 96, Screen.PixelsPerInch, 0, 0);
Dialog.Form.AutoScale;
// retrieve the results
result := Dialog.Form.ShowModal; result := Dialog.Form.ShowModal;
if Dialog.Form.Combo<>nil then begin if Dialog.Form.Combo<>nil then begin
SelectionRes := Dialog.Form.Combo.ItemIndex; SelectionRes := Dialog.Form.Combo.ItemIndex;