From 49647626a5045be8cc9c34abf517272f000d07ce Mon Sep 17 00:00:00 2001
From: Ondrej Pokorny <lazarus@kluug.net>
Date: Wed, 28 Sep 2022 16:25:06 +0200
Subject: [PATCH] LCL: task dialog: high-DPI support

---
 lcl/lcltaskdialog.pas | 459 +++++++++++++++---------------------------
 1 file changed, 158 insertions(+), 301 deletions(-)

diff --git a/lcl/lcltaskdialog.pas b/lcl/lcltaskdialog.pas
index ba485600ac..41c0b1a8b5 100644
--- a/lcl/lcltaskdialog.pas
+++ b/lcl/lcltaskdialog.pas
@@ -127,12 +127,12 @@ interface
 
 uses
   {$IFDEF MSWINDOWS}
-  Windows,
+  Windows, ctypes,
   {$ENDIF}
   Classes, SysUtils,
   LazUTF8,
-  LCLType, LCLStrConsts, LCLIntf, InterfaceBase,
-  LResources, Menus, Graphics, Forms, Controls, StdCtrls, ExtCtrls, Buttons;
+  LCLType, LCLStrConsts, LCLIntf, InterfaceBase, ImgList,
+  LResources, Menus, Graphics, Forms, Controls, StdCtrls, ExtCtrls, Buttons, DialogRes;
 
 {$IFDEF MSWINDOWS}
 var
@@ -415,9 +415,7 @@ function DefaultFont: TFont;
 
 implementation
 
-uses
-  Dialogs,
-  ImgList;
+Function LoadIconWithScaleDown( hinst:HINST; pszName:LPCWStr;cx:cint;cy:cint;var phico: HICON ):HRESULT; stdcall; external 'comctl32.dll' name 'LoadIconWithScaleDown';
 
 var
   LDefaultFont: TFont;
@@ -458,7 +456,6 @@ begin
     cbCancel: result := @rsMbCancel;
     cbRetry:  result := @rsMbRetry;
     cbClose:  result := @rsMbClose;
-        else  result := nil;
   end;
 end;
 
@@ -495,37 +492,16 @@ end;
 
 
 const
-  LAZ_ICONS: array[TTaskDialogIcon] of string = (
-    '', 'dialog_warning', 'dialog_confirmation', 'dialog_error', 'dialog_information', '', 'dialog_shield');
-  LAZ_FOOTERICONS: array[TTaskDialogFooterIcon] of string = (
-    '', 'dialog_warning', 'dialog_confirmation', 'dialog_error', 'dialog_information', 'dialog_shield');
+  LCL_IMAGES: array[TTaskDialogIcon] of Integer = (
+    0, idDialogWarning, idDialogConfirm, idDialogError, idDialogInfo, 0, idDialogShield);
+  LCL_FOOTERIMAGES: array[TTaskDialogFooterIcon] of Integer = (
+    0, idDialogWarning, idDialogConfirm, idDialogError, idDialogInfo, idDialogShield);
 {$IFDEF MSWINDOWS}
 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 = (
     0, 84, 99, 98, 81, 0, 78);
   TD_FOOTERICONS: array[TTaskDialogFooterIcon] of integer = (
     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}
 
 function IconMessage(Icon: TTaskDialogIcon): string;
@@ -636,200 +612,159 @@ function TTaskDialog.Execute(aCommonButtons: TCommonButtons;
   aRadioDef, aWidth: integer; aParent: HWND; aNonNative: boolean;
   aEmulateClassicStyle: boolean; aOnButtonClicked: TTaskDialogButtonClickedEvent): integer;
 
-function GetNextStringLineToWS(var P: PChar): WS;
-var S: PChar;
-    tmp: string;
-begin
-  if P=nil then
-    result := '' else begin
-    S := P;
-    while S[0]>=' ' do
-      inc(S);
-    SetString(tmp,P,S-P);
-    result := _WS(CR(tmp));
-    while (S^<>#0) and (S^<' ') do inc(S); // ignore e.g. #13 or #10
-    if S^<>#0 then
-      P := S else
-      P := nil;
+  function GetNextStringLineToWS(var P: PChar): WS;
+  var S: PChar;
+      tmp: string;
+  begin
+    if P=nil then
+      result := '' else begin
+      S := P;
+      while S[0]>=' ' do
+        inc(S);
+      SetString(tmp,P,S-P);
+      result := _WS(CR(tmp));
+      while (S^<>#0) and (S^<' ') do inc(S); // ignore e.g. #13 or #10
+      if S^<>#0 then
+        P := S else
+        P := nil;
+    end;
   end;
-end;
 
-var aHint: string;
+var
+  aHint: string;
 
-function NoCR(const aText: string): string;
-var i: integer;
-begin
-  result := aText;
-  aHint := '';
-  i := pos('\n',result);
-  if i>0 then begin
-    aHint := CR(copy(result,i+2,maxInt));
-    SetLength(result,i-1);
+  function NoCR(const aText: string): string;
+  var i: integer;
+  begin
+    result := aText;
+    aHint := '';
+    i := pos('\n',result);
+    if i>0 then begin
+      aHint := CR(copy(result,i+2,maxInt));
+      SetLength(result,i-1);
+    end;
   end;
-end;
 
 {$IFDEF MSWINDOWS}
 var RU: array of Ws;
     RUCount: integer;
     But: array of TTASKDIALOG_BUTTON;
-procedure AddRU(Text: string; var n: integer; firstID: integer);
-var P: PChar;
-begin
-  if Text='' then
-    exit;
-  Text := SysUtils.trim(Text);
-  P := @Text[1]; // '\n' handling in GetNextStringLineToWS(P) will change P^
-  while P<>nil do begin
-    if length(RU)<=RUCount then begin
-      SetLength(RU,RUCount+16);
-      SetLength(But,RUCount+16);
+  procedure AddRU(Text: string; var n: integer; firstID: integer);
+  var
+    P: PChar;
+  begin
+    if Text='' then
+      exit;
+    Text := SysUtils.trim(Text);
+    P := @Text[1]; // '\n' handling in GetNextStringLineToWS(P) will change P^
+    while P<>nil do begin
+      if length(RU)<=RUCount then begin
+        SetLength(RU,RUCount+16);
+        SetLength(But,RUCount+16);
+      end;
+      RU[RUCount] := GetNextStringLineToWS(P);
+      with But[RUCount] do begin
+        nButtonID := n+firstID;
+        pszButtonText := PWideChar(RU[RUCount]);
+      end;
+      inc(n);
+      inc(RUCount);
     end;
-    RU[RUCount] := GetNextStringLineToWS(P);
-    with But[RUCount] do begin
-      nButtonID := n+firstID;
-      pszButtonText := PWideChar(RU[RUCount]);
-    end;
-    inc(n);
-    inc(RUCount);
   end;
-end;
 {$ENDIF}
-var
-    {$IFDEF MSWINDOWS}
-    Config: TTASKDIALOGCONFIG;
-    {$ENDIF}
-    Pic: TPortableNetworkGraphic;
-    Ico: TIcon;
-    Bmp: TBitmap;
-    i, X, Y, XB, IconBorder, FontHeight: integer;
-    Par: TWinControl;
-    Panel: TPanel;
-    CurrTabOrder: TTabOrder;
-    Image: TImage;
-    List: TStrings;
-    B: TCommonButton;
-    CommandLink: TBitBtn;
-    Rad: array of TRadioButton = nil;
 
-function AddLabel(Text: string; BigFont: boolean): TLabel;
-var R: TRect;
-    W: integer;
-begin
-  result := TLabel.Create(Dialog.Form);
-  result.Parent := Par;
-  result.Font.PixelsPerInch := 96;
-  result.WordWrap := true;
-  if BigFont then begin
-    if aEmulateClassicStyle then begin
-      result.Font.Height := FontHeight-2;
-      result.Font.Style := [fsBold]
-    end else begin
-      result.Font.Height := FontHeight-4;
-      result.Font.Color := clHighlight;
+var
+  {$IFDEF MSWINDOWS}
+  Config: TTASKDIALOGCONFIG;
+  {$ENDIF}
+  i, X, Y, XB, IconBorder, FontHeight: integer;
+  Par: TWinControl;
+  Panel: TPanel;
+  CurrTabOrder: TTabOrder;
+  Image: TImageListImage;
+  List: TStrings;
+  B: TCommonButton;
+  CommandLink: TBitBtn;
+  Rad: array of TRadioButton = nil;
+
+  function AddLabel(Text: string; BigFont: boolean): TLabel;
+  var R: TRect;
+      W: integer;
+  begin
+    result := TLabel.Create(Dialog.Form);
+    result.Parent := Par;
+    result.WordWrap := true;
+    if BigFont then begin
+      if aEmulateClassicStyle then begin
+        result.Font.Height := FontHeight-2;
+        result.Font.Style := [fsBold]
+      end else begin
+        result.Font.Height := FontHeight-4;
+        result.Font.Color := clHighlight;
+      end;
+    end else
+      result.Font.Height := FontHeight;
+    result.AutoSize := false;
+    R.Left := 0;
+    R.Top := 0;
+    W := aWidth-X-8;
+    R.Right := W;
+    R.Bottom := result.Height;
+    LCLIntf.DrawText(result.Canvas.Handle,PChar(Text),Length(Text),R,DT_CALCRECT or DT_WORDBREAK);//lazarus does not return box height on OSX (Lazarus bug), the height is stored in the rect in all cases, so we don't need to use the result
+
+    result.SetBounds(X,Y,W,R.Bottom);
+    result.Caption := Text;
+    inc(Y,R.Bottom+16);
+  end;
+
+  procedure AddBevel;
+  var
+    BX: integer;
+  begin
+    with TBevel.Create(Dialog.Form) do begin
+      Parent := Par;
+      if (Image<>nil) and (Y<Image.Top+Image.Height) then
+        BX := X else
+        BX := 2;
+      SetBounds(BX,Y,aWidth-BX-2,2);
     end;
-  end else
-    result.Font.Height := FontHeight;
-  result.AutoSize := false;
-  R.Left := 0;
-  R.Top := 0;
-  W := aWidth-X-8;
-  R.Right := W;
-  R.Bottom := result.Height;
-  LCLIntf.DrawText(result.Canvas.Handle,PChar(Text),Length(Text),R,DT_CALCRECT or DT_WORDBREAK);//lazarus does not return box height on OSX (Lazarus bug), the height is stored in the rect in all cases, so we don't need to use the result
-
-  result.SetBounds(X,Y,W,R.Bottom);
-  result.Caption := Text;
-  inc(Y,R.Bottom+16);
-end;
-
-procedure AddBevel;
-var BX: integer;
-begin
-  with TBevel.Create(Dialog.Form) do begin
-    Parent := Par;
-    if (Image<>nil) and (Y<Image.Top+Image.Height) then
-      BX := X else
-      BX := 2;
-    SetBounds(BX,Y,aWidth-BX-2,2);
+    inc(Y,16);
   end;
-  inc(Y,16);
-end;
 
-function AddButton(const s: string; ModalResult: integer): TButton;
-var WB: integer;
-begin
-  WB := Dialog.Form.Canvas.TextWidth(s)+52;
-  dec(XB,WB);
-  if XB<X shr 1 then begin
-    XB := aWidth-WB;
-    inc(Y,32);
-  end;
-  result := TButton.Create(Dialog.Form);
-  result.Parent := Par;
-  result.Font.PixelsPerInch := 96;
-  if aEmulateClassicStyle then
-    result.SetBounds(XB,Y,WB-10,22)
-  else
-    result.SetBounds(XB,Y,WB-12,28);
-  result.Caption := s;
-  result.ModalResult := ModalResult;
-  result.TabOrder := CurrTabOrder;
-  result.OnClick := Dialog.Form.HandleEmulatedButtonClicked;
-  case ModalResult of
-    mrOk: begin
-      result.Default := true;
-      if aCommonButtons=[cbOk] then
-        result.Cancel := true;
+  function AddButton(const s: string; ModalResult: integer): TButton;
+  var
+    WB: integer;
+  begin
+    WB := Dialog.Form.Canvas.TextWidth(s)+52;
+    dec(XB,WB);
+    if XB<X shr 1 then begin
+      XB := aWidth-WB;
+      inc(Y,32);
     end;
-    mrCancel: result.Cancel := true;
+    result := TButton.Create(Dialog.Form);
+    result.Parent := Par;
+      if aEmulateClassicStyle then
+        result.SetBounds(XB,Y,WB-10,22)
+      else
+        result.SetBounds(XB,Y,WB-12,28);
+    result.Caption := s;
+    result.ModalResult := ModalResult;
+    result.TabOrder := CurrTabOrder;
+    result.OnClick := Dialog.Form.HandleEmulatedButtonClicked;
+    case ModalResult of
+      mrOk: begin
+        result.Default := true;
+        if aCommonButtons=[cbOk] then
+          result.Cancel := true;
+      end;
+      mrCancel: result.Cancel := true;
+    end;
+    if ModalResult=aButtonDef then
+      Dialog.Form.ActiveControl := result;
   end;
-  if ModalResult=aButtonDef then
-    Dialog.Form.ActiveControl := result;
-end;
-
-procedure AddImages(AImgList: TCustomImageList; AResName: String);
-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;
-  imgIndex: Integer;
-  imgRes: TScaledImageListResolution;
 begin
   if (byte(aCommonButtons)=0) and (Buttons='') then begin
     aCommonButtons := [cbOk];
@@ -896,7 +831,7 @@ begin
     Dialog.Form.Owner := @Self;
 
     // 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.BorderStyle := bsDialog;
     if tdfAllowDialogCancellation in aFlags then
@@ -922,10 +857,6 @@ begin
     Dialog.Form.ClientWidth := aWidth;
     Dialog.Form.Height := 200;
     Dialog.Form.Caption := Title;
-
-    // Prepare image list
-    PrepareImages;
-
     // create a white panel for the main dialog part
     Panel := TPanel.Create(Dialog.Form);
     Panel.Parent := Dialog.Form;
@@ -943,35 +874,13 @@ begin
     else
       IconBorder := 24;
 
-    if (LAZ_ICONS[aDialogIcon]<>'') {$IFDEF MSWINDOWS}or
-      ((WidgetSet.GetLCLCapability(lcNativeTaskDialog) = LCL_CAPABILITY_YES) and (WIN_ICONS[aDialogIcon]<>nil)){$ENDIF} then
+    if (LCL_IMAGES[aDialogIcon]<>0) then
     begin
-      Image := TImage.Create(Dialog.Form);
+      Image := TImageListImage.Create(Dialog.Form);
       Image.Parent := Par;
-      {$IFDEF MSWINDOWS}
-      if (WidgetSet.GetLCLCapability(lcNativeTaskDialog) = LCL_CAPABILITY_YES) and
-        (WIN_ICONS[aDialogIcon]<>nil) then
-          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);
+      Image.Images := GetDialogImages;
+      Image.ImageIndex := GetDialogImages.DialogIndexes[LCL_IMAGES[aDialogIcon]];
+      Image.SetBounds(IconBorder,IconBorder, 32, 32);
       X := Image.Width+IconBorder*2;
       Y := Image.Top;
       if aEmulateClassicStyle then
@@ -1011,6 +920,7 @@ begin
           Rad[i] := TRadioButton.Create(Dialog.Form);
           with Rad[i] do begin
             Parent := Par;
+            AutoSize := False;
             SetBounds(X+16,Y,aWidth-32-X, (6-FontHeight) + ARadioOffset);
             Caption := NoCR(Strings[i]);
             if aHint<>'' then begin
@@ -1065,11 +975,11 @@ begin
             end;
             if not (tdfUseCommandLinksNoIcon in aFlags) then
             begin
-              Images := imgList;
-              ImageIndex := imgList.GetImageIndex('btn_arrowright');
+              Images := LCLGlyphs;
+              ImageIndex := LCLGlyphs.GetImageIndex('btn_arrowright');
+              end;
             end;
           end;
-        end;
         inc(Y,24);
       finally
         Free;
@@ -1158,62 +1068,15 @@ begin
         AddBevel
       else
         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
-        Image := TImage.Create(Dialog.Form);
+        Image := TImageListImage.Create(Dialog.Form);
         Image.Parent := Par;
-        Pic := nil;
-        Ico := nil;
-        Bmp := TBitmap.Create;
-        try
-          Bmp.Transparent := true;
-          {$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;
+        Image.Images := GetDialogImages;
+        Image.ImageWidth := 16;
+        Image.ImageIndex := GetDialogImages.DialogIndexes[LCL_FOOTERIMAGES[aFooterIcon]];
+        Image.SetBounds(24,Y,16,16);
+        X := 40+Image.Width;
       end else
       begin
         X := 24;
@@ -1236,13 +1099,7 @@ begin
     if Assigned(Dialog.Form.PopupParent) then
       Dialog.Form.PopupMode := pmExplicit;
 
-
-    // Scale the dialog
-//    Dialog.Form.AutoAdjustLayout(lapAutoAdjustForDPI, 96, Screen.PixelsPerInch, 0, 0);
-    Dialog.Form.AutoScale;
-
-    // retrieve the results
-
+    // show the dialog - it will scale automatically in ShowModal
     result := Dialog.Form.ShowModal;
     if Dialog.Form.Combo<>nil then begin
       SelectionRes := Dialog.Form.Combo.ItemIndex;