From 92f83f8b5969e7e40ffb1c6fd87294f9e32a75fd Mon Sep 17 00:00:00 2001 From: Bart <9132501-flyingsheep@users.noreply.gitlab.com> Date: Mon, 24 Jul 2023 01:08:33 +0200 Subject: [PATCH] Refactoring TTaskDialog: - first attempt to get Win32 WS code working (currently littered with writeln() statements, so crashes if no console!) - fix ModalResult in OnButtonClicked for emulated dialog. --- lcl/dialogs.pp | 2 +- lcl/include/taskdialog.inc | 5 + lcl/interfaces/win32/win32wsdialogs.pp | 261 ++++++++++++++++++++++++- lcl/lcltaskdialog.pas | 1 + lcl/taskdlgemulation.pp | 27 ++- 5 files changed, 284 insertions(+), 12 deletions(-) diff --git a/lcl/dialogs.pp b/lcl/dialogs.pp index c047680817..2fb56154a6 100644 --- a/lcl/dialogs.pp +++ b/lcl/dialogs.pp @@ -639,7 +639,6 @@ type var ACanClose: Boolean); procedure SetButtons(const Value: TTaskDialogButtons); procedure SetRadioButtons(const Value: TTaskDialogButtons); - function ButtonIDToModalResult(const AButtonID: Integer): TModalResult; protected class procedure WSRegisterClass; override; function DoExecute(ParentWnd: HWND): Boolean; dynamic; @@ -649,6 +648,7 @@ type constructor Create(AOwner: TComponent); override; destructor Destroy; override; + function ButtonIDToModalResult(const AButtonID: Integer): TModalResult; function Execute: Boolean; overload; dynamic; function Execute(ParentWnd: HWND): Boolean; overload; dynamic; property Button: TTaskDialogButtonItem read FButton write FButton; diff --git a/lcl/include/taskdialog.inc b/lcl/include/taskdialog.inc index 35efd7a606..d5d370f412 100644 --- a/lcl/include/taskdialog.inc +++ b/lcl/include/taskdialog.inc @@ -242,6 +242,11 @@ begin debugln(['New: FModalResult=',FModalResult]); debugln(['New: VerifyChecked=',tfVerificationFlagChecked in FFlags]); debugln(['New: ARadioRes=',ARadioRes]); + + + + + FillChar(TaskDlg, SizeOf(LCLTaskDialog.TTaskDialog), 0); if RadioButtons.DefaultButton<> nil then diff --git a/lcl/interfaces/win32/win32wsdialogs.pp b/lcl/interfaces/win32/win32wsdialogs.pp index 4ef492657b..94a2bb988f 100644 --- a/lcl/interfaces/win32/win32wsdialogs.pp +++ b/lcl/interfaces/win32/win32wsdialogs.pp @@ -180,6 +180,9 @@ var implementation +uses + TaskDlgEmulation; + function SaveApplicationState: TApplicationState; begin Result.ActiveWindow := Windows.GetActiveWindow; @@ -1615,15 +1618,262 @@ var begin Result := 0; for aFlag := Low(TTaskDialogFlags) to High(TTaskDialogFlags) do - if (aFlag in aFlags) then Result := Result or FlagValues[aFlag]; + if (aFlag in aFlags) then + Result := Result or FlagValues[aFlag]; +end; + +function TaskDialogCommonButtonsToInteger(const Buttons: TTaskDialogCommonButtons): Integer; +const + CommonButtonValues: Array[TTaskDialogCommonButton] of Integer = ( + TDCBF_OK_BUTTON,// tcbOk + TDCBF_YES_BUTTON, //tcbYes + TDCBF_NO_BUTTON, //tcbNo + TDCBF_CANCEL_BUTTON, //tcbCancel + TDCBF_RETRY_BUTTON, //tcbRetry + TDCBF_CLOSE_BUTTON //tcbClose + ); +var + B: TTaskDialogCommonButton; +begin + Result := 0; + for B in TTaskDialogCommonButton do + begin + if B in Buttons then + Result := Result or CommonButtonValues[B]; + end; +end; + +function TaskDialogCallbackProc(hwnd: HWND; uNotification: UINT; + wParam: WPARAM; {%H-}lParam: LPARAM; dwRefData: Long_Ptr): HRESULT; stdcall; +var Dlg: TTaskDialog absolute dwRefData; + CanClose: Boolean; +begin + writeln('TaskDialogCallbackProc: uNotification=',uNotification); + //ptd^.Dialog.Wnd := hwnd; + Result := S_OK; + + if not (Dlg is TCustomTaskDialog) then + begin + writeln('TaskDialogCallbackProc: Dlg is NOT a TCustomTaskDialog'); + Exit; + end; + + case uNotification of + TDN_BUTTON_CLICKED: + //if Assigned(ptd^.Dialog.OnButtonClicked) then + if Assigned(Dlg.OnButtonClicked) then + begin + CanClose := True; + //ptd^.Dialog.OnButtonClicked(ptd,wParam,CanClose); + Dlg.OnButtonClicked(Dlg, Dlg.ButtonIDToModalResult(wParam), CanClose); + if not CanClose then + Result := S_FALSE; + end; + end; +end; + + +type + TWideStringArray = array of WideString; + TButtonArray = array of TTASKDIALOG_BUTTON; + +procedure PrepareTaskDialogConfig(const ADlg: TTaskDialog; AParent: HWND; out Config: TTaskDialogConfig; + out RU: TWideStringArray; out But: TButtonArray); +var + WindowTitle, MainInstruction, Content, VerificationText, + ExpandedInformation, ExpandedControlText, CollapsedControlText, + Footer: WideString; + DefRB, DefBtn, RUCount: Integer; + CommonButtons: TTaskDialogCommonButtons; + B: TTaskDialogBaseButtonItem; + List: TStringList; + //RU: Array of WideString; + //But: array of TTASKDIALOG_BUTTON; + Flags: TTaskDialogFlags; +const + TD_BTNMOD: array[TTaskDialogCommonButton] of Integer = ( + mrOk, mrYes, mrNo, mrCancel, mrRetry, mrAbort); + TD_ICONS: array[TLCLTaskDialogIcon] of integer = ( + 0, 84, 99, 98, 81, 0, 78); + TD_FOOTERICONS: array[TLCLTaskDialogFooterIcon] of integer = ( + 0, 84, 99, 98, 65533, 65532); + + procedure AddRU(List: TStringList; var n: longword{integer}; firstID: integer); + var + P: PChar; + i: Integer; + begin + if (List.Count = 0) then + Exit; + //P := @Text[1]; // '\n' handling in GetNextStringLineToWS(P) will change P^ + //while P<>nil do + for i := 0 to List.Count - 1 do + begin + if length(RU)<=RUCount then + begin + SetLength(RU,RUCount+16); + SetLength(But,RUCount+16); + end; + RU[RUCount] := Utf8ToUtf16(List[i]);//GetNextStringLineToWS(P); + But[RUCount].nButtonID := n+firstID; + But[RUCount].pszButtonText := PWideChar(RU[RUCount]); + inc(n); + inc(RUCount); + end; + end; + + function DialogBaseUnits: Integer; + //https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getdialogbaseunits + type + TLongRec = record L, H: Word; end; + begin + Result := TLongRec(GetDialogBaseUnits).L; + end; + + +begin + WindowTitle := Utf8ToUtf16(ADlg.Caption); + if (WindowTitle = '') then + begin + if (Application.MainForm = nil) then + WindowTitle := Utf8ToUtf16(Application.Title) + else + WindowTitle := Utf8ToUtf16(Application.MainForm.Caption); + end; + MainInstruction := Utf8ToUtf16(ADlg.Title); + if (MainInstruction = '') then + MainInstruction := Utf8ToUtf16(IconMessage(TF_DIALOGICON(ADlg.MainIcon))); + Content := Utf8ToUtf16(ADlg.Text); + CollapsedControlText := Utf8ToUtf16(ADlg.ExpandButtonCaption); + VerificationText := Utf8ToUtf16(ADlg.VerificationText); + if (aParent = 0) then + begin + if Assigned(Screen.ActiveCustomForm) then + aParent := Screen.ActiveCustomForm.Handle + else + aParent := 0; + end; + ExpandedInformation := Utf8ToUtf16(ADlg.ExpandedText); + ExpandedControlText := ''; //currently no matching field in TTaskDialog?? + CollapsedControlText := Utf8ToUtf16(ADlg.ExpandButtonCaption); + Footer := Utf8ToUtf16(ADlg.FooterText); + + if ADlg.RadioButtons.DefaultButton<> nil then + DefRB := ADlg.RadioButtons.DefaultButton.Index + else + DefRB := 0; + if ADlg.Buttons.DefaultButton<>nil then + DefBtn := ADlg.Buttons.DefaultButton.ModalResult + else + DefBtn := TD_BTNMOD[ADlg.DefaultButton]; + + + if (ADlg.CommonButtons = []) and (ADlg.Buttons.Count = 0) then + begin + CommonButtons := [tcbOk]; + if (DefBtn = 0) then + DefBtn := mrOK; + end; + + writeln('PrepareTaskDialogConfig A'); + + Config := Default(TTaskDialogConfig); + Config.cbSize := SizeOf(TTaskDialogConfig); + Config.hwndParent := aParent; + Config.pszWindowTitle := PWideChar(WindowTitle); + Config.pszMainInstruction := PWideChar(MainInstruction); + Config.pszContent := PWideChar(Content); + Config.pszVerificationText := PWideChar(VerificationText); + Config.pszExpandedInformation := PWideChar(ExpandedInformation); + Config.pszCollapsedControlText := PWideChar(CollapsedControlText); + Config.pszExpandedControlText := PWideChar(ExpandedControlText); + Config.pszFooter := PWideChar(Footer); + Config.nDefaultButton := DefBtn; + + writeln('PrepareTaskDialogConfig B'); + + + RUCount := 0; + List := TStringList.Create; + try + for B in ADlg.Buttons do + List.Add(B.Caption); + AddRU(List,Config.cButtons,TaskDialogFirstButtonIndex); + writeln('PrepareTaskDialogConfig C'); + + List.Clear; + for B in ADlg.RadioButtons do + List.Add(B.Caption); + AddRU(List,Config.cRadioButtons,TaskDialogFirstRadioButtonIndex); + writeln('PrepareTaskDialogConfig D'); + + finally + List.Free; + end; + + writeln('PrepareTaskDialogConfig E'); + + if (Config.cButtons > 0) then + Config.pButtons := @But[0]; + writeln('PrepareTaskDialogConfig F: Config.cButtons=',Config.cButtons,', Config.pButtons=',PtrInt(Config.pButtons)); + + if (Config.cRadioButtons > 0) then + Config.pRadioButtons := @But[Config.cButtons {Config.cRadioButtons}]; + writeln('PrepareTaskDialogConfig G',', Config.pRadioButtons=',PtrInt(Config.pRadioButtons)); + + + Config.dwCommonButtons := TaskDialogCommonButtonsToInteger(ADlg.CommonButtons); + writeln('PrepareTaskDialogConfig H'); + + + Flags := ADlg.Flags; + writeln('PrepareTaskDialogConfig I'); + if (VerificationText <> '') and (tfVerificationFlagChecked in ADlg.Flags) then + Include(Flags,tfVerificationFlagChecked) + else + Exclude(Flags,tfVerificationFlagChecked); + writeln('PrepareTaskDialogConfig J'); + if (Config.cButtons=0) and (CommonButtons=[tcbOk]) then + Include(Flags,tfAllowDialogCancellation); // just OK -> Esc/Alt+F4 close + writeln('PrepareTaskDialogConfig K'); + + + Config.dwFlags := TaskDialogFlagsToInteger(Flags); + writeln('PrepareTaskDialogConfig L'); + + + Config.hMainIcon := TD_ICONS[TF_DIALOGICON(ADlg.MainIcon)]; + writeln('PrepareTaskDialogConfig M'); + Config.hFooterIcon := TD_FOOTERICONS[TF_FOOTERICON(ADlg.FooterIcon)]; + writeln('PrepareTaskDialogConfig N'); + + { + Although the offcial MS docs (https://learn.microsoft.com/en-us/windows/win32/api/commctrl/ns-commctrl-taskdialogconfig) + states that setting the flag TDF_NO_DEFAULT_RADIO_BUTTON should cause that no radiobutton + is selected when the dialog displays, testing shows that (at least on Win10) this only + works correctly if nDefaultRadioButton does NOT point to a radiobutton in the pRadioButtons array. + } + if not (tfNoDefaultRadioButton in ADlg.Flags) then + Config.nDefaultRadioButton := DefRB + TaskDialogFirstRadioButtonIndex; + writeln('PrepareTaskDialogConfig O'); + + Config.cxWidth := MulDiv(ADlg.FWidth, 4, DialogBaseUnits); // cxWidth needed in "dialog units" + writeln('PrepareTaskDialogConfig P'); + + Config.pfCallback := @TaskDialogCallbackProc; + writeln('PrepareTaskDialogConfig Q'); + Config.lpCallbackData := LONG_PTR(ADlg); + writeln('PrepareTaskDialogConfig R'); end; class function TWin32WSTaskDialog.Execute(const ADlg: TCustomTaskDialog; AParentWnd: HWND; out ARadioRes: Integer): Integer; var Config: TTASKDIALOGCONFIG; VerifyChecked: BOOL; + RU: TWideStringArray; + BUT: TButtonArray; begin - writeln('TWin32WSTaskDialog.Execute'); + writeln('TWin32WSTaskDialog.Execute A'); if not Assigned(TaskDialogIndirect) or (tfForceNonNative in ADlg.Flags) //Yet to be implemented: or (ADlg.Selection <> '') or (tfQuery in ADlg.Flags) @@ -1631,12 +1881,19 @@ begin Result := inherited Execute(ADlg, AParentWnd, ARadioRes) else begin + writeln('TWin32WSTaskDialog.Execute B'); + PrepareTaskDialogConfig(TTaskDialog(ADlg), AParentWnd, Config, RU, BUT); + writeln('TWin32WSTaskDialog.Execute C'); + Result := TaskDialogIndirect(@Config, @Result, @ARadioRes, @VerifyChecked); + writeln('TWin32WSTaskDialog.Execute D'); + //for now let it fail, it's not functional yet. Result := -1; if (Result = S_OK) then begin + writeln('TWin32WSTaskDialog.Execute E'); if VerifyChecked then ADlg.Flags := ADlg.Flags + [tfVerificationFlagChecked] else diff --git a/lcl/lcltaskdialog.pas b/lcl/lcltaskdialog.pas index 708d3a9c1b..f5798e4cd9 100644 --- a/lcl/lcltaskdialog.pas +++ b/lcl/lcltaskdialog.pas @@ -772,6 +772,7 @@ var end; if ModalResult=aButtonDef then Dialog.Form.ActiveControl := result; + writeln('AddButton: Result.ModalResult=',Result.ModalResult); end; {$IFDEF MSWINDOwS} function TaskDialogFlagsToInteger(aFlags: TTaskDialogFlags): Integer; diff --git a/lcl/taskdlgemulation.pp b/lcl/taskdlgemulation.pp index a96b4dd293..215858f4e2 100644 --- a/lcl/taskdlgemulation.pp +++ b/lcl/taskdlgemulation.pp @@ -74,6 +74,19 @@ var function ExecuteLCLTaskDialog(const ADlg: TTaskDialog; AParentWnd: HWND; out ARadioRes: Integer): Integer; + +type + TLCLTaskDialogIcon = ( + tiBlank, tiWarning, tiQuestion, tiError, tiInformation, tiNotUsed, tiShield); + TLCLTaskDialogFooterIcon = ( + tfiBlank, tfiWarning, tfiQuestion, tfiError, tfiInformation, tfiShield); + +function IconMessage(Icon: TLCLTaskDialogIcon): string; +function TF_DIALOGICON(const aIcon: TTaskDialogIcon): TLCLTaskDialogIcon; +function TF_FOOTERICON(const aIcon: TTaskDialogIcon): TLCLTaskDialogFooterIcon; + + + implementation var @@ -102,11 +115,6 @@ begin {$ENDIF} end; -type - TLCLTaskDialogIcon = ( - tiBlank, tiWarning, tiQuestion, tiError, tiInformation, tiNotUsed, tiShield); - TLCLTaskDialogFooterIcon = ( - tfiBlank, tfiWarning, tfiQuestion, tfiError, tfiInformation, tfiShield); const LCL_IMAGES: array[TLCLTaskDialogIcon] of Integer = ( @@ -593,9 +601,10 @@ procedure TLCLTaskDialog.HandleEmulatedButtonClicked(Sender: TObject); var Btn: TButton absolute Sender; CanClose: Boolean; begin - if Assigned(FDlg) and Assigned(FDlg.OnButtonClicked) then begin + if Assigned(FDlg) and Assigned(FDlg.OnButtonClicked) then + begin CanClose := True; - FDlg.OnButtonClicked(FDlg,Btn.ModalResult,CanClose); + FDlg.OnButtonClicked(FDlg, FDlg.ButtonIDToModalResult(Btn.ModalResult),CanClose); if not CanClose then ModalResult := mrNone; end; @@ -627,9 +636,9 @@ begin CustomButtons := TStringList.Create; for B in FDlg.Buttons do - CustomButtons.Add(B.Caption); + CustomButtons.Add(B.Caption); //********** ModalResult and Default??? Radios := TStringList.Create; - for B in FDlg.RadioButtons do + for B in FDlg.RadioButtons do //********** Default? Radios.Add(B.Caption); //ToDo