mORMot Open Source

reddwarf

Member

Registered: 2010-06-28

Posts: 40

Website

SynTaskDialog.pas for Lazarus

Hello Arnauld!

I modified your SynTaskDialog.pas to be compatible with Lazarus (Windows, Linux, OSX). I also fixed some small issues. I would be happy if you added my changes to the trunk so that I have them available when I update Synopse!

Here is the patch code (if you want me to send you the whole file, I can do so as well).

3c3
< // licensed under a MPL/GPL/LGPL tri-license; version 1.18
---
> // licensed under a MPL/GPL/LGPL tri-license; version 1.19
32a33
>   - Ondrej Pokorny (reddwarf)
70a72,79
>   Version 1.19 (Ondrej Pokorny)
>   - added Lazarus support (native on Windows Vista+, emulated on all other
>     platforms - Windows, Linux and OSX tested)
>   - added external translation function for the emulated dialog
>    (TaskDialog_Translate)
>   - Alt+F4 is blocked now in emulated dialog (same behaviour in native)
>   - TODO: platform-independent icons
> 
78a88,100
>   {$IF (CompilerVersion >= 25.0)}// Delphi XE4 UP
>     {$LEGACYIFEND ON}
>   {$IFEND}
>   {$IF CompilerVersion >= 20}// Delphi 2009 IP
>     {$define WITHPOPUPPARENT}
>     {$define WITHNATIVEINT}
>   {$IFEND}
> {$ENDIF}
> {$IFDEF FPC}
>   {$MODE DELPHI}
>   {$define WITHUXTHEME}
>   {$define WITHPOPUPPARENT}
>   {$define WITHNATIVEINT}
82c104,111
<   Windows, CommCtrl, Classes, SysUtils, Consts, Messages,
---
>   {$IFDEF FPC}
>   LCLType, LCLStrConsts, LCLIntf,
>   {$ENDIF}
>   {$IFDEF MSWINDOWS}
>   Windows, CommCtrl, Messages,
>   {$ENDIF}
>   Classes, SysUtils,
>   {$IFNDEF FPC}Consts,{$ENDIF}
100a130
> {$IFDEF MSWINDOWS}
106c136
< 
---
> {$ENDIF}
164a195,198
>     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
> 
>     constructor CreateNew(AOwner: TComponent; Num: Integer = 0); override;
>   public
278c312
<     VerifyChecked: BOOL;
---
>     VerifyChecked: Boolean;
301c335
<       aFooterIcon: TTaskDialogFooterIcon=tfiWarning;
---
>       {%H-}aFooterIcon: TTaskDialogFooterIcon=tfiWarning;
303c337
<       aNonNative: boolean=false; aEmulateClassicStyle: boolean = false;
---
>       {%H-}aNonNative: boolean=false; aEmulateClassicStyle: boolean = false;
424a459,464
> //function for translating the captions
> type
>   TTaskDialogTranslate = function(const aString: string): string;
> var
>   TaskDialog_Translate: TTaskDialogTranslate;
> 
426a467
> {$IFDEF MSWINDOWS}
428c469
< 
---
> {$ENDIF}
437,442c478,483
<     cbOK:     result := @SMsgDlgOK;
<     cbYes:    result := @SMsgDlgYes;
<     cbNo:     result := @SMsgDlgNo;
<     cbCancel: result := @SMsgDlgCancel;
<     cbRetry:  result := @SMsgDlgRetry;
<     cbClose:  result := @SCloseButton;
---
>     cbOK:     result := {$ifndef fpc}@SMsgDlgOK{$else}@rsMbOK{$endif};
>     cbYes:    result := {$ifndef fpc}@SMsgDlgYes{$else}@rsMbYes{$endif};
>     cbNo:     result := {$ifndef fpc}@SMsgDlgNo{$else}@rsMbNo{$endif};
>     cbCancel: result := {$ifndef fpc}@SMsgDlgCancel{$else}@rsMbCancel{$endif};
>     cbRetry:  result := {$ifndef fpc}@SMsgDlgRetry{$else}@rsMbRetry{$endif};
>     cbClose:  result := {$ifndef fpc}@SCloseButton{$else}@rsMbClose{$endif};
446a488,495
> function TD_Trans(const aString: string): string;
> begin
>   if Assigned(TaskDialog_Translate) then
>     Result := TaskDialog_Translate(aString)
>   else
>     Result := aString;
> end;
> 
455c504,505
<   Caption := LoadResString(TD_BTNS(Btn));
---
>   Caption := TD_Trans(LoadResString(TD_BTNS(Btn)));
> 
489a540,559
>   {$IFDEF FPC}
>   function StripHotkey(const Text: string): string;
>   var
>     I: Integer;
>   begin
>     Result := Text;
>     I := 1;
>     while I <= Length(Result) do
>     begin
>       if Result[i] = cHotkeyPrefix then
>         if SysLocale.FarEast and
>           ((I > 1) and (Length(Result)-I >= 2) and
>            (Result[I-1] = '(') and (Result[I+2] = ')')) then
>           Delete(Result, I-1, 4)
>         else
>           Delete(Result, I, 1);
>       Inc(I);
>     end;
>   end;
>   {$ENDIF}
491c561
<   result := StripHotkey(s);
---
>   Result := StripHotkey(s);
496a567
> {$IFDEF MSWINDOWS}
497a569,591
>   {$IFDEF FPC}
>     {$EXTERNALSYM IDI_APPLICATION}
>     IDI_APPLICATION = MakeIntResource(32512);
>     {$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_SHIELD}
>     IDI_SHIELD  = MakeIntResource(32518);
>     {$EXTERNALSYM IDI_WARNING}
>     IDI_WARNING = IDI_EXCLAMATION;
>     {$EXTERNALSYM IDI_ERROR}
>     IDI_ERROR = IDI_HAND;
>     {$EXTERNALSYM IDI_INFORMATION}
>     IDI_INFORMATION = IDI_ASTERISK;
>   {$ENDIF}
> 
505a600
> {$ENDIF MSWINDOWS}
510,513c605,608
<     tiWarning:   result := SMsgDlgWarning;
<     tiQuestion:  result := SMsgDlgConfirm;
<     tiError:     result := SMsgDlgError;
<     tiInformation, tiShield: result := SMsgDlgInformation;
---
>     tiWarning:   result := {$ifndef fpc}SMsgDlgWarning{$else}rsMtWarning{$endif};
>     tiQuestion:  result := {$ifndef fpc}SMsgDlgConfirm{$else}rsMtConfirmation{$endif};
>     tiError:     result := {$ifndef fpc}SMsgDlgError{$else}rsMtError{$endif};
>     tiInformation, tiShield: result := {$ifndef fpc}SMsgDlgInformation{$else}rsMtInformation{$endif};
515a611
>   result := TD_Trans(result);
517a614
> {$IFDEF MSWINDOWS}
526a624
> {$ENDIF}
531a630,638
> function _WS(const aString: string): WideString;
> begin
>   {$IFDEF FPC}
>   Result := UTF8Decode(aString);
>   {$ELSE}
>   Result := WS(aString);
>   {$ENDIF}
> end;
> 
541a649
> {$IFDEF MSWINDOWS}
597a706
> {$ENDIF}
618c727
<     result := WideString(CR(tmp));
---
>     result := _WS(CR(tmp));
642c751
<     result := WS(CR(aText));
---
>     result := _WS(CR(aText));
643a753
> {$IFDEF MSWINDOWS}
668c778,784
< var Config: TTASKDIALOGCONFIG;
---
> {$ENDIF}
> var
>     {$IFDEF MSWINDOWS}
>     Config: TTASKDIALOGCONFIG;
>     Pic: TIcon;
>     Bmp: TBitmap;
>     {$ENDIF}
674,675d789
<     Pic: TIcon;
<     Bmp: TBitmap;
704c818,819
<   R.Bottom := DrawText(result.Canvas.Handle,pointer(Text),-1,R,DT_CALCRECT or DT_WORDBREAK);
---
>   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
> 
766c881
<       aParent := Application.Handle;
---
>       aParent := {$ifndef fpc}Application.Handle{$else}0{$endif};
767a883
>   {$ifdef MSWINDOWS}
805a922
>   {$endif MSWINDOWS}
817a935,938
>     {$IFDEF FPC}
>     if FontHeight = 0 then
>       FontHeight := Screen.SystemFont.Height;
>     {$ENDIF}
840c961
<       {$ifdef WITHUXTHEME}
---
>       {$ifdef WITHUXTHEME}{$ifndef FPC}
842c963
<       {$endif}
---
>       {$endif}{$endif}
848a970
>     {$IFDEF MSWINDOWS}//TODO: custom icons for other platforms
858c980,982
<     end else begin
---
>     end else
>     {$ENDIF}
>     begin
994c1118
<           AddButton(LoadResString(TD_BTNS(B)), TD_BTNMOD[b]);
---
>           AddButton(TD_Trans(LoadResString(TD_BTNS(B))), TD_BTNMOD[b]);
1015a1140
>       {$IFDEF MSWINDOWS}//TODO: custom icons for other platforms
1036a1162,1163
>       {$ENDIF}
>       begin
1037a1165
>       end;
1041a1170,1187
> 
>     //set form parent
>     {$IFDEF WITHPOPUPPARENT}
>     if aParent <> 0 then
>       for I := 0 to Screen.CustomFormCount-1 do
>         if Screen.CustomForms[i].Handle = aParent then
>         begin
>           Dialog.Form.PopupParent := Screen.CustomForms[i];
>           Break;
>         end;
>     if not Assigned(Dialog.Form.PopupParent) then
>       Dialog.Form.PopupParent := Screen.ActiveCustomForm;
>     if Assigned(Dialog.Form.PopupParent) then
>     begin
>       Dialog.Form.PopupMode := pmExplicit;
>     end;
>     {$ENDIF}
> 
1061a1208
> {$IFDEF MSWINDOWS}
1063a1211
> {$ENDIF}
1068c1216,1218
<       Dialog.Form.Element[element].Caption := CR(Text) else
---
>       Dialog.Form.Element[element].Caption := CR(Text)
>     {$IFDEF MSWINDOWS}
>     else
1070c1220,1221
<         {$ifdef UNICODE}NativeInt{$else}integer{$endif}(pointer(WS(Text))));
---
>         {$ifdef WITHNATIVEINT}NativeInt{$else}integer{$endif}(pointer(_WS(Text))))
>     {$ENDIF};
1082a1234,1240
> constructor TEmulatedTaskDialog.CreateNew(AOwner: TComponent; Num: Integer);
> begin
>   inherited CreateNew(AOwner, Num);
> 
>   KeyPreview := True;
> end;
> 
1094a1253,1260
> procedure TEmulatedTaskDialog.KeyDown(var Key: Word; Shift: TShiftState);
> begin
>   if (Key = VK_F4) and (ssAlt in Shift) then//IMPORTANT: native task dialog blocks Alt+F4 to close the dialog -> we have to block it as well
>     Key := 0;
> 
>   inherited KeyDown(Key, Shift);
> end;
> 
1115a1282,1284
>     {$IFDEF FPC}
>     DefaultFont.Size := 11;//Lazarus seems not to like the height property -> we must use Size
>     {$ELSE}
1116a1286
>     {$ENDIF}
1121a1292,1294
>     {$IFDEF FPC}
>     DefaultFont.Size := 10;//Lazarus seems not to like the height property -> we must use Size
>     {$ELSE}
1122a1296
>     {$ENDIF}
1124a1299
>   {$IFDEF MSWINDOWS}
1125a1301
>   {$ENDIF}
1128a1305
>   {$IFDEF MSWINDOWS}//TODO: lazarus resource
1129a1307
>   {$ENDIF}
1131a1310
>   {$IFDEF MSWINDOWS}//TODO: lazarus resource
1132a1312
>   {$ENDIF}

reddwarf

Member

Registered: 2010-06-28

Posts: 40

Website

Re: SynTaskDialog.pas for Lazarus

Allow me one more question: what about initializing the TTaskDialog to an empty object? Doesn't it have to be done? What if there is some garbage data from previous calls?

procedure Test;
var Task: TTaskDialog;
begin
  Task.Inst := 'Saving application settings';
  Task.Content := 'This is the content';
  Task.Radios := 'Store settings in registry'#10'Store settings in XML file';
  Task.Verify := 'Do no ask for this setting next time';
  Task.VerifyChecked := true;
  Task.Footer := 'XML file is perhaps a better choice';
  Task.Execute([],0,[],tiQuestion,tfiInformation,200);
  ShowMessage(IntToStr(Task.RadioRes)); // 200=Registry, 201=XML
  if Task.VerifyChecked then
    ShowMessage(Task.Verify);
end;

gkovacs

Member

Registered: 2012-03-09

Posts: 3

Re: SynTaskDialog.pas for Lazarus

Could you post a full source, I'm very interested - patching seems to produce an invalid source - for me at least.
Thanks!

Last edited by gkovacs (2015-03-06 11:25:41)

reddwarf

Member

Registered: 2010-06-28

Posts: 40

Website

Re: SynTaskDialog.pas for Lazarus

I sent the full source to Arnauld already. If you want me to send it to you as well, write me an email through the forum.

Last edited by reddwarf (2015-03-06 13:07:31)

uligerhardt

Member

Registered: 2011-03-08

Posts: 52

Re: SynTaskDialog.pas for Lazarus

Hello Arnauld and reddwarf!

FWIW: I just gave this version of the unit a quick test in my VCL app and had one compiler error, probably because I always compile with TYPEDADDRESS ON. The call to TaskDialogIndirect in line 930 yields an error "E2010 Inkompatible Typen: 'PBOOL' und 'Pointer'". I fixed this by introducing a local variable "bVerifyChecked: BOOL" and call TaskDialogIndirect like this:

    bVerifyChecked := VerifyChecked;
    if TaskDialogIndirect(@Config,@result,@RadioRes,@bVerifyChecked)=S_OK then
    begin
      VerifyChecked := bVerifyChecked;
      exit; // error (mostly invalid argument) -> execute the VCL emulation
    end;

After that, I didn't notice any errors.

uligerhardt

Member

Registered: 2011-03-08

Posts: 52

Re: SynTaskDialog.pas for Lazarus

Allow me one more question: what about initializing the TTaskDialog to an empty object? Doesn't it have to be done? What if there is some garbage data from previous calls?

I guess you're right there. I always use TTaskDialogEx like this:

procedure Test;
var
  Task: TTaskDialogEx;
begin
  Task := DefaultTaskDialog;
  //...
end;

, so never had problems from this. You could probably also use:

procedure Test;
var
  Task: TTaskDialog;
begin
  Task := DefaultTaskDialog.Base;
  //...
end;