From b6d0978768b96e72a165842def5718de07fb26ab Mon Sep 17 00:00:00 2001 From: ondrej Date: Wed, 21 Sep 2016 16:06:29 +0000 Subject: [PATCH] LCL: include LCLTaskDialog.pas, initial commit. Issue #30625 git-svn-id: trunk@53006 - --- .gitattributes | 3 + lcl/alllclunits.pp | 2 +- lcl/btn_icons.res | Bin 7144 -> 8812 bytes lcl/dialog_icons.res | Bin 7038 -> 8907 bytes lcl/images/buttons/btn_arrowright.png | Bin 0 -> 1608 bytes lcl/images/buttons/build.bat | 2 +- lcl/images/copyright.txt | 16 +- lcl/images/dialogs/build.bat | 2 +- lcl/images/dialogs/dialog_shield.png | Bin 0 -> 1811 bytes lcl/lclbase.lpk | 6 +- lcl/lcltaskdialog.pas | 1234 +++++++++++++++++++++++++ 11 files changed, 1254 insertions(+), 11 deletions(-) create mode 100644 lcl/images/buttons/btn_arrowright.png create mode 100644 lcl/images/dialogs/dialog_shield.png create mode 100644 lcl/lcltaskdialog.pas diff --git a/.gitattributes b/.gitattributes index 205aa03368..92afd27534 100644 --- a/.gitattributes +++ b/.gitattributes @@ -6831,6 +6831,7 @@ lcl/images/btnselfile.png -text svneol=unset#image/png lcl/images/btntime.png -text svneol=unset#image/png lcl/images/buttons/btn_abort.png -text svneol=unset#image/png lcl/images/buttons/btn_all.png -text svneol=unset#image/png +lcl/images/buttons/btn_arrowright.png -text lcl/images/buttons/btn_cancel.png -text svneol=unset#image/png lcl/images/buttons/btn_close.png -text svneol=unset#image/png lcl/images/buttons/btn_help.png -text svneol=unset#image/png @@ -6872,6 +6873,7 @@ lcl/images/dialogs/build.bat svneol=native#text/x-msdos-program lcl/images/dialogs/dialog_confirmation.png -text svneol=unset#image/png lcl/images/dialogs/dialog_error.png -text svneol=unset#image/png lcl/images/dialogs/dialog_information.png -text svneol=unset#image/png +lcl/images/dialogs/dialog_shield.png -text lcl/images/dialogs/dialog_warning.png -text svneol=unset#image/png lcl/images/dock/lcl_dock_close.png -text svneol=unset#image/png lcl/images/dock/lcl_dock_images.bat svneol=native#text/x-msdos-program @@ -7704,6 +7706,7 @@ lcl/lclmessageglue.pas svneol=native#text/pascal lcl/lclproc.pas svneol=native#text/pascal lcl/lclrescache.pas svneol=native#text/pascal lcl/lclstrconsts.pas svneol=native#text/pascal +lcl/lcltaskdialog.pas svneol=native#text/pascal lcl/lcltranslator.pas svneol=native#text/pascal lcl/lcltype.pp svneol=native#text/pascal lcl/lclunicodedata.pas svneol=native#text/pascal diff --git a/lcl/alllclunits.pp b/lcl/alllclunits.pp index 4555f360cb..52e597f531 100644 --- a/lcl/alllclunits.pp +++ b/lcl/alllclunits.pp @@ -28,7 +28,7 @@ uses CustomDrawnControls, CustomDrawnDrawers, LazDeviceApis, LDockTree, LazFreeTypeIntfDrawer, CustomDrawn_WinXP, CustomDrawn_Android, Arrow, EditBtn, ComboEx, DBExtCtrls, CustomDrawn_Mac, CalcForm, LCLTranslator, - GroupedEdit, LazarusPackageIntf; + GroupedEdit, LCLTaskDialog, LazarusPackageIntf; implementation diff --git a/lcl/btn_icons.res b/lcl/btn_icons.res index 67f2ecc559bb7e100081a14b31044ebe053d65ab..f7dab571056eb807643f604d79365e0bf3a6557a 100644 GIT binary patch delta 1619 zcmb7EYfuwc7+rZNLd;MBYpK|Ep##z;yPMats{ymwP+|$sR1g)7$to#iHpC6D&U)zIxtMdsjZgU4G-HNjx*hz*}3=b`Of+7 zx!-pOu_3B?@YV3R=>V`80Dz}YeE||M0tvusKm()*Zz7N;eD%OvKpbG))$Sc34is>K zK0*LcSr#&D7wQ?#ds?iGJUo6D&oA=imb*z5+wGiJs)X_a6a>@wM5REoehn|o*DXeXCK z|C`5i(N1H5ord`o+R5fR%(Q?Hor)Ihd$E!mD5OIqI;_IEm~trAoNJ>QPEV;J;g8f} zwGfnCuFwb$>M*Tbr$AAX#1*)XL}F1HDI=AN2@c*sJTDlN$x#_jl2HhvMNyp!Cn+4q zbg@x5siR1QoJv5?I5`tzrl*9hg79Rl=7q6@)?1`FB1?(+CgxlAnyMd%(rD}Q0~tbu4o=o*L69((jl_5pxLp`Owh zUDx~gYC~3lCUE0TM%C1lt}RJdc0|-1qbh1$zkN~~^mWk4^-Vrq6|RVfU~o#+9lj!+ zPY5QD9xQbo3f7g)4?J*8UB9=fL-jiP^deKFI=QH=U$L*LZ07usKi1tE9>Un)FN#m` zSO3~KbCH;+zs-&wDzto5w>7NevS)xYIx6oTe^w_Nqc$&f{+e-Qq`hGnEfUX3Df)JB zto6}rtJ;fAsb9ut`^xKbHbsxz zFKf&6$}P)k_gj6#AP+cf4f=9P{DN6W!WK|E&&uXiH@#2TYkTtwjWx1?4KGb|ID$(f zrX`mzd9bq<_pcZE=Poa<2$H7-bZ+mM5qOyYuvE%?6Bj-k_G`&`H?Q{eiPUrDU4dV` z(RxVa*C+Ctow^gYbnn@1-E1TL&bBrU^}l^-M~(Q{EBLmfp%?C-f4ExR#t%pLJPt)0 zneMMHd3=vG4GrGsWa=-g{newSh_xgj~yGuRc8cd(=+ zsNZwuj=I)@8_CJbMh33j*{crldk|e3-FsR*tFJNgv*Qcfdv2Jv4tsCMc4pQ$T_0G| ry|7!N&)9wB@xcp`bjE1$nB){t5bje}osczO3uyomas&ea diff --git a/lcl/dialog_icons.res b/lcl/dialog_icons.res index 99a6afdb1c6679473b49cbfbefd887da5f35a746..bbc50e19106fc3f66a70f3742f4f646b14cf8862 100644 GIT binary patch delta 1840 zcmV-02haHaHp@k@ej6tM022oQ05|{u0RR6A07L*u06_pu08ao%0AB!807w8y07U>y z07Q{dHh%yabVXQnQ*UN;cVTj606}DLVr3vnZDD6+Qe|Oed2z{QJOBU&wMj%lRCwCN zS8Hq(RTMsR=e4uj^6GYhD)L7R1VN+3KVmc@peDw|Cy7z{VMsJFvDg+YHMVLE(IATW zh>1qU7ho~UQ-6p&N(+=4NeJq;3Uu3obo<J?G)z!F_sLd%H}C@QrCZ>z=E8uCY*>$0YFD zYqc@Ukspyn@mWPtOBXL*BG0<|8Uek7!GFPi=pP&aJu?DVlwHXeqSVGU2!z8CP-GR- z>0vnbQ;T)@a5KSl{f?2^s7U6fl`Cs|FG>LO8`3mo2|n=zb?Dt?Wo6dQH{YUOHDe~2 zrU9u`3R1&EkU?N@xJxh%)4-m0914^Zq3mM_g*4FAF#p-9Q-8pL13&7?-d+L%*?&e& zbHnP@HHY#D)Ya7~p|GsugU-T*3!Q6b%_fm>7}5xqN)2(3OvB)yf@kcAmPDB^9Nfto z>{Cbjzf>KmbQNhJZyogxr?eWK!3)j!Tf#~`ObRs$wFM1xyzy^V+>Nd+r~c;!VU zNo*S&9E73a0XTcE8-_6CmT3V&P{Kg@IiG|R^qj}SefO_?@j281-OwSKOac)|Jg7I4 z6$QYFzP?`cOvc3}1Qxj0Yyo@-?}OkHH$V6M<$3R$d*LpOngUspS-CnW$bZ&?1T52T zI&QtiAra_-f&?-dtHm@;C!J11SPT1U@y<@( zeKxlqcrX%>7ZtZO!`P(y`hWXCl*MFK)$@flfI`fm*!CtmI~*+(;knK>49^oEj4kSa zmuHlY5~dplRS7}7Ep9s&Z5Z8cN$|$D?Js|7Z80>A09Hi+l)A?2+XjkzfKPx1(*QYO z{~B`&y}iBAdh8gb0^K?$0ml-)NpyB%ueTtig|Z>c83U)lzSprgWPicw=t#I{8-E`O z7eP@`5sZwa2lZk5$1w?1S63&ofkCHO+bN1fsyar?vw} zTaK_$eXyo{P4{IHV25GRitoPPV>2=<=b zRaIT%BH(t$OnFmNQ<`m1vC?TE%Tg{4SOr#rHjF~!{X>ydtovW-=`*KKO)Q?gZmiMl zq68``YI~?-Kk~(wpBo`ngOVvxzDHPI1lZXHrrC03t$XsMD4&jY?A)1gEaRRPD^{3) zivT-TSFYJ2zRZKi~WrYZ8xER@THX zHSCg0{a`qyS9f=v{h^^@ixG=XgR<#mpoKM8gb2mQQn{K>GYHVt>;_Ab8=|{4{vRBBLx=uwcg0yY6_ZxVU)9z`($sZ@2G!=fv?7=kPnz zGd*C8M0&g_2ojMzV4ncHXTt)CMx%01PmkrzD%1lp11T`Q&;Ol2rvXwz;5s)r_oOUNxwp>1=}W!I$EK0Qc;<;4YY$MT^gWp6C8>b z7%F!l;%*;$h_VgOb54g2(9^+iehmkk0)DeO500C7bJMXcMe6p4=O4>m^80$9=Y4;`EcGZk0w>8@0FN`Daw|P5aFSQa&3)St z2uzx=c`EQpP-cA^prsiSkc(lF6;{B20udup8H%E>0umU3Ay@(-5)pzbr4l6!15*#k zd1GujN+X^;<%?UXKs(F2ln_)@R3t8vifJYnLNE;TaY!U0&O+oardW$dM7d-93^?hw zG7cB(peew|XjxAeuqu#?^vM;RF1`LKG3A~TijxfTSX>Yyh9RfZcdtonH)|yS4da>C zZd0*~gp8z{E?}%&K5}CGU{1T|JMtNF(I{6i4lXH{e4MrxI7y1t;VO_j5!)O#B`%f9 z)SP|gQsWT86Z+G-IOae18R`*=d$`+i4e|&5#3`4$4LsxqZob za#x&W9EGGUnW3G)q`FGSGrT8D5H*YoO7f_x5}!`Wd@<<$bPTqfRLzM5V`ND zs%dv?m*QpQ@AFit;>41UA=#eR%2^Adf6uuwI)c)_ofn)eyZq;#SxW@UrknKmffCz? zjay^8E(S)(6B7#WoFVuV_~zyAU$PF5bvBP8rGh!e(r@lgv_E`lZD+Y9Fo4RT5d-yU(uai zn#dj+Xc`EL?pYJu+m`Sd3P%sk+_t-Gh)%jO-_Uq$Z`_Iw{^KBQz;IcXHg{ju+AG50 z!0^-!6(&W%s&{9C5ioT($a(0z%5^`htR-z2UGve59^5tGzGX(umX!^A9U-w`02I3p zd9fmOVc6l=g*Xvdb7<}L>Bn6S1BE4~ddcvH7p5_c&>J@`y=vM09SvA`6FTAy|WMARCSb%CiXvyL0YK3FE0dqhqjK~z42q-J0rxk z#jCT$`5J!8_`Tcg*dJ{j-oGYV+P;^ifazpy=KEJxD}D%RG}aAwH*busg=fd#toA%^ zzSEuibDOR}+x*i|`1sr_wV@Z1Yz5Kz;?w9Q{&bs#C>(q-*D{AmBVcrt6ed_r`R XSG*{=vd&;%;QP1h2m^jlv#$IfF2Pcs literal 0 HcmV?d00001 diff --git a/lcl/images/buttons/build.bat b/lcl/images/buttons/build.bat index a2eeaa5eaf..97267e25e9 100644 --- a/lcl/images/buttons/build.bat +++ b/lcl/images/buttons/build.bat @@ -1 +1 @@ -..\..\..\tools\lazres ..\..\btn_icons.res btn_abort.png btn_all.png btn_cancel.png btn_close.png btn_help.png btn_ignore.png btn_no.png btn_ok.png btn_retry.png btn_yes.png +..\..\..\tools\lazres ..\..\btn_icons.res btn_abort.png btn_all.png btn_cancel.png btn_close.png btn_help.png btn_ignore.png btn_no.png btn_ok.png btn_retry.png btn_yes.png btn_arrowright.png diff --git a/lcl/images/copyright.txt b/lcl/images/copyright.txt index 027b8e3f82..c9ca3df47f 100644 --- a/lcl/images/copyright.txt +++ b/lcl/images/copyright.txt @@ -3,25 +3,27 @@ LICENSE AND COPYRIGHT INFORMATION ABOUT IMAGES USED IN LCL Public domain Tango https://packages.debian.org/sid/tango-icon-theme PNG versions: http://http.debian.net/debian/pool/main/t/tango-icon-theme/tango-icon-theme_0.8.90.orig.tar.gz -- dialogs/* +- btncalendar.png +- btncalculator.png +- btnfiltercancel.png - btnselfile.png - btnseldir.png +- btntime.png (modified Appointment.svg by Michael Fuchs) - dbnavcancel.png - dbnavdelete.png - dbnavrefresh.png - dbnavnext.png +- dbnavedit.png (modified Edit-metadata.svg by Ondrej Pokorny) - dbnavlast.png - dbnavinsert.png - dbnavfirst.png +- dbnavpost.png (modified Text-x-generic-apply.svg by Ondrej Pokorny) - dbnavprior.png -- btntime.png (modified Appointment.svg by Michael Fuchs) -- btncalendar.png -- btncalculator.png -- btnfiltercancel.png +- dialogs/dialog_shield.png (modified network-wireless-encrypted.png by Ondrej Pokorny) +- dialogs/* - sortasc.png - sortdesc.png -- dbnavpost.png (modified Text-x-generic-apply.svg by Ondrej Pokorny) -- dbnavedit.png (modified Edit-metadata.svg by Ondrej Pokorny) +- buttons/btn_arrowright.png (modified go-next.png by Ondrej Pokorny) - buttons/* - button/btn_ok.png (modified Text-x-generic-apply.svg by Ondrej Pokorny) - button/btn_yes.png (modified Text-x-generic-apply.svg by Ondrej Pokorny) diff --git a/lcl/images/dialogs/build.bat b/lcl/images/dialogs/build.bat index 65caab33b0..321cee57c4 100644 --- a/lcl/images/dialogs/build.bat +++ b/lcl/images/dialogs/build.bat @@ -1 +1 @@ -..\..\..\tools\lazres ..\..\dialog_icons.res dialog_confirmation.png dialog_error.png dialog_information.png dialog_warning.png +..\..\..\tools\lazres ..\..\dialog_icons.res dialog_confirmation.png dialog_error.png dialog_information.png dialog_warning.png dialog_shield.png \ No newline at end of file diff --git a/lcl/images/dialogs/dialog_shield.png b/lcl/images/dialogs/dialog_shield.png new file mode 100644 index 0000000000000000000000000000000000000000..dbd6488beb8cc540df413d0a2fa5161fc72e36e7 GIT binary patch literal 1811 zcmV+u2kiKXP)1qU7ho~UQ-6p&N(+=4 zNeJq;3Uu3obo<g(&LDk143+qUk+r(afOV_kW9ZU1=I@EsS}#pM#Ht*s?$SY9p?vVQ*j>%#Nq&Xe}; z+iP@obsFHnD+Htsm6esl{|SM$YwMSa5_w%!wORMw|A0Jw>NK!y8zf1B^XLDBUAuP} z$z+c~DSg)@&RaFl)^z-10$a9h5!+Aw_JAZxFAzdzExLU%xpwY6Vp%5i5A=efD8SZH zRTVTX0zEzF;o!l2dRu$DOo;G}X*=tlt9-7pP@2ai@Y-v&G0Tx3kwo!XMNvx^FJ2m5m00m(&=G1_EU>>_;549bp4Kz+Nen8 zrj;vedoM}=^BdAMWeGm<1a;`$Wo2d7%{SkoUNvJTn5F@#R0>kVLy$pWaJWk_4b#A$ zcN_|o6QS&52!%Az)G+_qsZ)QzfdfD4$=+T90@+4QbHnP@HHY#D)Ya7~p|GsugU-T* z3!Q6b%_fm>7}5xqN)2(3OvB)yf@kcAmPDB^9Nfto> z{Cbjzf>KmbQNhJZyogxr?eWK!3)j!Tf#~`ObR@*j0ue|&s5g=o1;B~EzFzc9#>FKB7P!}J0elGW zgWwW3Kll9QdGDKh;Vz7t0$Gw-xjHDw)`A2q({4I*=8Vqr#%f!DT)w#>Ax6R_LOAH? z+`Gc^BanMBGORk<+uL+}=1@TbsK&;4+i#L2%OJ_3D>yHN+=7IB5&>Yxiv-Q;!sWuN zj7JhsR~;b{=z)R+G8wDIG)*U+PD5A=`)TpcPTqYsw;p&f5|9@aw=~1pr26{%K$OK~ zRn_x_HGo3QpxE{%Iy)RK6ydqfHVn@bAB-*Pf0t*JjuNID22}|`ye)1!7Ht^aZAtLP zw(T!}YHcwzi~v?e0F=7M>)Qs3dw@@X2GamJVE-C(3cbC((0c3`r2^eLCIQD1zDaa; zVz0L#q=m8}%ozixz`ob9H)O%-=t#I{8-E`O7eP@`5sZwa2lZk5$1w?1S63&oUXm0;K zPA5;8!b>s-Zu1$yj{*-h&3W$xqQJbTwgX37j<8UDu%>)X_hk`ahhfo*@4nw-GcmFr z?&mWv3XA~I0C>*WZzfMF!RirJqQl^M>5ktd&8@&1gNGZ!s; zaG5-kNkiA!PTb{y3$7?U5&OLgn?C*6OmrqT)xWg1jujJ{9ynX$8Os&4P|zZgi1tkR z(=W$jvAZ66@L{neT8gt`inm(az+l_g4R#`t_;mfc4I4ec%qSZPlDHIs(8X-|^2hF- zGk5mN*>mQQn{K>GYHVt>;_q`It002ovPDHLkV1mn- BUDN;o literal 0 HcmV?d00001 diff --git a/lcl/lclbase.lpk b/lcl/lclbase.lpk index 3d0993f479..f98c85c24c 100644 --- a/lcl/lclbase.lpk +++ b/lcl/lclbase.lpk @@ -27,7 +27,7 @@ - + @@ -1176,6 +1176,10 @@ + + + + diff --git a/lcl/lcltaskdialog.pas b/lcl/lcltaskdialog.pas new file mode 100644 index 0000000000..157394ebb8 --- /dev/null +++ b/lcl/lcltaskdialog.pas @@ -0,0 +1,1234 @@ +{ + /*************************************************************************** + LCLTaskDialog.pas + ----------------- + + Implement TaskDialog window (native on Vista/Seven, emulated on XP). + This unit was originally a part of the freeware Synopse mORMot framework, + licensed under a MPL/GPL/LGPL tri-license; version 1.19. + It has been relicensed with permission from Arnaud Bouchez, the original + author, and all contributors. + + The original name is SynTaskDialog.pas + + ***************************************************************************/ + + ***************************************************************************** + This file is part of the Lazarus Component Library (LCL) + + See the file COPYING.modifiedLGPL.txt, included in this distribution, + for details about the license. + ***************************************************************************** +} + + +unit LCLTaskDialog; + +{ + This file is part of Synopse framework. + + Synopse framework. Copyright (C) 2016 Arnaud Bouchez + Synopse Informatique - http://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2016 + the Initial Developer. All Rights Reserved. + + Contributor(s): + - Ulrich Gerhardt + - Ondrej Pokorny (reddwarf) + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + + Version 1.13 + - initial release + + Version 1.15 + - new tdfQueryMasked function to display * in the tdfQuery editor field + + Version 1.16 + - fixed issue when changing the current application with Alt+Tab - see + http://synopse.info/fossil/tktview?name=01395e5932 + - fixed compiler error when using the unit with runtime packages enabled + (known compiler issue about string resources, referenced as E2201) + - default modal dialog parent changed into any current active form + - added tdfQueryFieldFocused optional flag to focus the input field component + - some aesthetical rendering changes and code clean-up (e.g. no temporary + form necessary), thanks to uligerhardt proposals + + Version 1.18 + - fixed label height display when long text is wrapped on several lines + - bottom buttons use better looking TButton component + - bottom buttons won't trim expected shortcut definition, in emulated mode + - added OnButtonClicked property and associated SetElementText() method + - now compiles and run in Win64 platform (Delphi XE2+) + + 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) + - tdfAllowDialogCancellation handled in emulated dialog: + - if not set: Alt+F4 is blocked + - if set: Esc is allowed + - tdfPositionRelativeToWindow handled in emulated dialog + - platform-independent icons are from www.iconsdb.com: + Icon license: + This icon is provided as CC0 1.0 Universal (CC0 1.0) Public Domain + Dedication. + You can copy, modify, use, distribute this icon, even for commercial + purposes, all without asking permission with no attribution required, + but always appreciated. + - Maybe To-Do: High DPI-aware emulated dialog + icons + - Just a remark: native dialogs don't work in non-unicode applications + (Delphi 7 etc.) because the TaskDialogIndirect is not available for + non-unicode applications (Windows limitation) + http://msgroups.net/microsoft.public.vc.mfc/getprocaddress-ansi-unicode/571937 + +} + +interface + +{$MODE DELPHI} +{$IFNDEF MSWINDOWS} + {$define WITHLAZARUSICONS} +{$ENDIF} + +uses + LCLType, LCLStrConsts, LCLIntf, + {$IFDEF MSWINDOWS} + Windows, CommCtrl, Messages, + {$ENDIF} + LResources, Classes, SysUtils, + Menus, Graphics, Forms, Controls, StdCtrls, ExtCtrls, Buttons; + +var + /// will map a default font, according to the available + // - if Calibri is installed, will use it + // - will fall back to Tahoma otherwise + DefaultFont: TFont; + +{$IFDEF MSWINDOWS} + /// is filled once in the initialization block below + // - you can set this reference to nil to force Delphi dialogs even + // on Vista/Seven (e.g. make sense if TaskDialogBiggerButtons=true) + TaskDialogIndirect: function(AConfig: pointer; Res: PInteger; + ResRadio: PInteger; VerifyFlag: PBOOL): HRESULT; stdcall; +{$ENDIF} +type + /// the standard kind of common buttons handled by the Task Dialog + TCommonButton = ( + cbOK, cbYes, cbNo, cbCancel, cbRetry, cbClose); + + /// set of standard kind of common buttons handled by the Task Dialog + TCommonButtons = set of TCommonButton; + + /// the available main icons for the Task Dialog + TTaskDialogIcon = ( + tiBlank, tiWarning, tiQuestion, tiError, tiInformation, tiNotUsed, tiShield); + + /// the available footer icons for the Task Dialog + TTaskDialogFooterIcon = ( + tfiBlank, tfiWarning, tfiQuestion, tfiError, tfiInformation, tfiShield); + + /// the available configuration flags for the Task Dialog + // - most are standard TDF_* flags used for Vista/Seven native API + // (see http://msdn.microsoft.com/en-us/library/bb787473(v=vs.85).aspx + // for TASKDIALOG_FLAGS) + // - tdfQuery and tdfQueryMasked are custom flags, implemented in pure Delphi + // code to handle input query + // - our emulation code will handle only tdfUseCommandLinks, + // tdfUseCommandLinksNoIcon, and tdfQuery options + TTaskDialogFlag = ( + tdfEnableHyperLinks, tdfUseHIconMain, tdfUseHIconFooter, + tdfAllowDialogCancellation, tdfUseCommandLinks, tdfUseCommandLinksNoIcon, + tdfExpandFooterArea, tdfExpandByDefault, tdfVerificationFlagChecked, + tdfShowProgressBar, tdfShowMarqueeProgressBar, tdfCallbackTimer, + tdfPositionRelativeToWindow, tdfRtlLayout, tdfNoDefaultRadioButton, + tdfCanBeMinimized, tdfQuery, tdfQueryMasked, tdfQueryFieldFocused); + + /// set of available configuration flags for the Task Dialog + TTaskDialogFlags = set of TTaskDialogFlag; + + PTaskDialog = ^TTaskDialog; + + /// this callback will be triggerred when a task dialog button is clicked + // - to prevent the task dialog from closing, the application must set + // ACanClose to FALSE, otherwise the task dialog is closed and the button + // ID is returned via the original TTaskDialog.Execute() result + TTaskDialogButtonClickedEvent = procedure(Sender: PTaskDialog; + AButtonID: integer; var ACanClose: Boolean) of object; + + /// the visual components of this Task Dialog + // - map low-level TDE_CONTENT...TDE_MAIN_INSTRUCTION constants and + // the query editor and checkbox + // - tdeEdit is for the query editor + // - tdeVerif is for the checkbox + TTaskDialogElement = ( + tdeContent, tdeExpandedInfo, tdeFooter, tdeMainInstruction, + tdeEdit, tdeVerif); + + /// the actual form class used for emulation + TEmulatedTaskDialog = class(TForm) + protected + procedure HandleEmulatedButtonClicked(Sender: TObject); + public + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + + constructor CreateNew(AOwner: TComponent; Num: Integer = 0); override; + public + /// the Task Dialog structure which created the form + Owner: PTaskDialog; + /// the labels corresponding to the Task Dialog main elements + Element: array[tdeContent..tdeMainInstruction] of TLabel; + /// the Task Dialog selection list + Combo: TComboBox; + /// the Task Dialog optional query editor + Edit: TEdit; + /// the Task Dialog optional checkbox + Verif: TCheckBox; + end; + + /// structure for low-level access to the task dialog implementation + // - points either to the HWND handle of the new TaskDialog API + // or to the emulation dialog + TTaskDialogImplementation = record + OnButtonClicked: TTaskDialogButtonClickedEvent; + case Emulated: Boolean of + False: (Wnd: HWND); + True: (Form: TEmulatedTaskDialog); + end; + + /// implements a TaskDialog + // - will use the new TaskDialog API under Vista/Seven, and emulate it with + // pure Delphi code and standard themed VCL components under XP or 2K + // - create a TTaskDialog object/record on the stack will initialize all + // its string parameters to '' (it's a SHAME that since Delphi 2009, objects + // are not initialized any more: we have to define this type as object before + // Delphi 2009, and as record starting with Delphi 2009) + // - set the appropriate string parameters, then call Execute() with all + // additional parameters + // - RadioRes/SelectionRes/VerifyChecked will be used to reflect the state + // after dialog execution + // - here is a typical usage: + // !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; + TTaskDialog = record + /// the main title of the dialog window + // - if left void, the title of the application main form is used + Title: string; + /// the main instruction (first line on top of window) + // - any '\n' will be converted into a line feed + // - if left void, the text is taken from the current dialog icon kind + Inst: string; + /// the dialog's primary content content text + // - any '\n' will be converted into a line feed + Content: string; + /// a #13#10 or #10 separated list of custom buttons + // - they will be identified with an ID number starting at 100 + // - by default, the buttons will be created at the dialog bottom, just + // like the common buttons + // - if tdfUseCommandLinks flag is set, the custom buttons will be created + // as big button in the middle of the dialog window; in this case, any + // '\n' will be converted as note text (shown with smaller text under native + // Vista/Seven TaskDialog, or as popup hint within Delphi emulation) + Buttons: string; + /// a #13#10 or #10 separated list of custom radio buttons + // - they will be identified with an ID number starting at 200 + // - aRadioDef parameter can be set to define the default selected value + // - '\n' will be converted as note text (shown with smaller text under + // native Vista/Seven TaskDialog, or as popup hint within Delphi emulation) + Radios: string; + /// the expanded information content text + // - any '\n' will be converted into a line feed + // - the Delphi emulation will always show the Info content (there is no + // collapse/expand button) + Info: string; + /// the button caption to be displayed when the information is collapsed + // - not used under XP: the Delphi emulation will always show the Info content + InfoExpanded: string; + /// the button caption to be displayed when the information is expanded + // - not used under XP: the Delphi emulation will always show the Info content + InfoCollapse: string; + /// the footer content text + // - any '\n' will be converted into a line feed + Footer: string; + /// the text of the bottom most optional checkbox + Verify: string; + /// a #13#10 or #10 separated list of items to be selected + // - if set, a Combo Box will be displayed to select + // - if tdfQuery is in the flags, the combo box will be in edition mode, + // and the user will be able to edit the Query text or fill the field + // with one item of the selection + // - this selection is not handled via the Vista/Seven TaskDialog, but + // with our Delphi emulation code (via a TComboBox) + Selection: string; + /// some text to be edited + // - if tdfQuery is in the flags, will contain the default query text + // - if Selection is set, the + Query: string; + /// the selected radio item + // - first is numeroted 0 + RadioRes: integer; + /// after execution, contains the selected item from the Selection list + SelectionRes: integer; + /// reflect the the bottom most optional checkbox state + // - if Verify is not '', should be set before execution + // - after execution, will contain the final checkbox state + VerifyChecked: Boolean; + /// low-level access to the task dialog implementation + Dialog: TTaskDialogImplementation; + + /// launch the TaskDialog form + // - some common buttons can be set via aCommonButtons + // - in emulation mode, aFlags will handle only tdfUseCommandLinks, + // tdfUseCommandLinksNoIcon, and tdfQuery options + // - will return 0 on error, or the Button ID (e.g. mrOk for the OK button + // or 100 for the first custom button defined in Buttons string) + // - if Buttons was defined, aButtonDef can set the selected Button ID + // - if Radios was defined, aRadioDef can set the selected Radio ID + // - aDialogIcon and aFooterIcon are used to specify the displayed icons + // - aWidth can be used to force a custom form width (in pixels) + // - aParent can be set to any HWND - by default, Application.DialogHandle + // - if aNonNative is TRUE, the Delphi emulation code will always be used + // - aEmulateClassicStyle can be set to enforce conformity with the non themed + // user interface - see @http://synopse.info/forum/viewtopic.php?pid=2867#p2867 + // - aOnButtonClicked can be set to a callback triggerred when a button is + // clicked + function Execute(aCommonButtons: TCommonButtons=[]; + aButtonDef: integer=0; aFlags: TTaskDialogFlags=[]; + aDialogIcon: TTaskDialogIcon=tiInformation; + {%H-}aFooterIcon: TTaskDialogFooterIcon=tfiWarning; + aRadioDef: integer=0; aWidth: integer=0; aParent: HWND=0; + {%H-}aNonNative: boolean=false; aEmulateClassicStyle: boolean = false; + aOnButtonClicked: TTaskDialogButtonClickedEvent=nil): integer; + + /// allow a OnButtonClicked callback to change the Task Dialog main elements + // - note that tdeVerif could be modified only in emulation mode, since + // the API does not give any runtime access to the checkbox caption + // - other elements will work in both emulated and native modes + procedure SetElementText(element: TTaskDialogElement; const Text: string); + end; + + /// a wrapper around the TTaskDialog.Execute method + // - used to provide a "flat" access to task dialog parameters + TTaskDialogEx = record + /// the associated main TTaskDialog instance + Base: TTaskDialog; + /// some common buttons to be displayed + CommonButtons: TCommonButtons; + /// the default button ID + ButtonDef: integer; + /// the associated configuration flags for this Task Dialog + // - in emulation mode, aFlags will handle only tdfUseCommandLinks, + // tdfUseCommandLinksNoIcon, and tdfQuery options + Flags: TTaskDialogFlags; + /// used to specify the dialog icon + DialogIcon: TTaskDialogIcon; + /// used to specify the footer icon + FooterIcon: TTaskDialogFooterIcon; + /// the default radio button ID + RadioDef: integer; + /// can be used to force a custom form width (in pixels) + Width: integer; + /// if TRUE, the Delphi emulation code will always be used + NonNative: boolean; + /// can be used to enforce conformity with the non themed user interface + EmulateClassicStyle: boolean; + /// this event handler will be fired on a button dialog click + OnButtonClicked: TTaskDialogButtonClickedEvent; + /// will initialize the dialog parameters + // - can be used to display some information with less parameters: + // !var TaskEx: TTaskDialogEx; + // ! ... + // ! TaskEx.Init; + // ! TaskEx.Base.Title := 'Task Dialog Test'; + // ! TaskEx.Base.Inst := 'Callback Test'; + // ! TaskEx.Execute; + procedure Init; + /// main (and unique) method showing the dialog itself + // - is in fact a wrapper around the TTaskDialog.Execute method + function Execute(aParent: HWND=0): integer; + end; + +/// return the text without the '&' characters within +function UnAmp(const s: string): string; + +var + /// a default Task Dialog wrapper instance + // - can be used to display some information with less parameters, just + // like the TTaskDialogEx.Init method: + // !var TaskEx: TTaskDialogEx; + // ! ... + // ! TaskEx := DefaultTaskDialog; + // ! TaskEx.Base.Title := 'Task Dialog Test'; + // ! TaskEx.Base.Inst := 'Callback Test'; + // ! TaskEx.Execute; + DefaultTaskDialog: TTaskDialogEx = ( + DialogIcon: tiInformation; + FooterIcon: tfiWarning); + +//function for translating the captions +type + TTaskDialogTranslate = function(const aString: string): string; +var + TaskDialog_Translate: TTaskDialogTranslate; + +implementation + +const + TD_BTNMOD: array[TCommonButton] of Integer = ( + mrOk, mrYes, mrNo, mrCancel, mrRetry, mrAbort); + +function TD_BTNS(button: TCommonButton): pointer; +begin + case button of + cbOK: result := @rsMbOK; + cbYes: result := @rsMbYes; + cbNo: result := @rsMbNo; + cbCancel: result := @rsMbCancel; + cbRetry: result := @rsMbRetry; + cbClose: result := @rsMbClose; + else result := nil; + end; +end; + +function TD_Trans(const aString: string): string; +begin + if Assigned(TaskDialog_Translate) then + Result := TaskDialog_Translate(aString) + else + Result := aString; +end; + +function UnAmp(const s: string): string; + 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; +begin + Result := StripHotkey(s); +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'); +{$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 = ( + 17, 84, 99, 98, 81, 0, 78); + TD_FOOTERICONS: array[TTaskDialogFooterIcon] of integer = ( + 17, 84, 99, 98, 65533, 65532); + WIN_ICONS: array[TTaskDialogIcon] of PChar = ( + nil, IDI_WARNING, IDI_QUESTION, IDI_ERROR, IDI_INFORMATION, nil, IDI_WINLOGO); + WIN_FOOTERICONS: array[TTaskDialogFooterIcon] of PChar = ( + nil, IDI_WARNING, IDI_QUESTION, IDI_ERROR, IDI_INFORMATION, IDI_WINLOGO); +{$ENDIF MSWINDOWS} + +function IconMessage(Icon: TTaskDialogIcon): string; +begin + case Icon of + tiWarning: result := rsMtWarning; + tiQuestion: result := rsMtConfirmation; + tiError: result := rsMtError; + tiInformation, tiShield: result := rsMtInformation; + else result := ''; + end; + result := TD_Trans(result); +end; + +{$IFDEF MSWINDOWS} +procedure InitComCtl6; +var OSVersionInfo: TOSVersionInfo; +begin + OSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo); + GetVersionEx(OSVersionInfo); + if OSVersionInfo.dwMajorVersion<6 then + @TaskDialogIndirect := nil else + @TaskDialogIndirect := GetProcAddress(GetModuleHandle(comctl32),'TaskDialogIndirect'); +end; +{$ENDIF} + +type + /// internal type used for Unicode string storage + WS = WideString; + +function _WS(const aString: string): WS; +begin + Result := UTF8Decode(aString); +end; + +function CR(const aText: string): string; +begin + if pos('\n', aText) = 0 then + result := aText else + result := StringReplace(aText, '\n', #10, [rfReplaceAll]); +end; + + +{ TTaskDialog } + +{$IFDEF MSWINDOWS} +type + // see http://msdn.microsoft.com/en-us/library/bb787473 + PTASKDIALOG_BUTTON = ^TTASKDIALOG_BUTTON; + TTASKDIALOG_BUTTON = packed record + nButtonID: integer; + pszButtonText: PWideChar; + end; + + TTASKDIALOGCONFIG = packed record + cbSize: integer; + hwndParent: HWND; + hInstance: THandle; + dwFlags: cardinal; + dwCommonButtons: cardinal; + pszWindowTitle: PWideChar; + hMainIcon: HICON; + pszMainInstruction: PWideChar; + pszContent: PWideChar; + cButtons: integer; + pButtons: PTASKDIALOG_BUTTON; + nDefaultButton: integer; + cRadioButtons: integer; + pRadioButtons: PTASKDIALOG_BUTTON; + nDefaultRadioButton: integer; + pszVerificationText: PWideChar; + pszExpandedInformation: PWideChar; + pszExpandedControlText: PWideChar; + pszCollapsedControlText: PWideChar; + hFooterIcon: HICON; + pszFooter: PWideChar; + pfCallback: pointer; + lpCallbackData: pointer; + cxWidth: integer; + end; + +const + TDN_BUTTON_CLICKED = 2; // wParam = Button ID + + +function TaskDialogCallbackProc(hwnd: HWND; uNotification: UINT; + wParam: WPARAM; {%H-}lParam: LPARAM; dwRefData: pointer): HRESULT; stdcall; +var ptd: PTaskDialog absolute dwRefData; + CanClose: Boolean; +begin + ptd^.Dialog.Wnd := hwnd; + Result := S_OK; + case uNotification of + TDN_BUTTON_CLICKED: + if Assigned(ptd^.Dialog.OnButtonClicked) then begin + CanClose := True; + ptd^.Dialog.OnButtonClicked(ptd,wParam,CanClose); + if not CanClose then + Result := S_FALSE; + end; + end; +end; +{$ENDIF} + +function TTaskDialog.Execute(aCommonButtons: TCommonButtons; + aButtonDef: integer; aFlags: TTaskDialogFlags; + aDialogIcon: TTaskDialogIcon; aFooterIcon: TTaskDialogFooterIcon; + 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; + end; +end; +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); + end; +end; +function N(const aText: string): WS; +begin + if aText='' then + result := '' else + result := _WS(CR(aText)); +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); + 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} + {$IFDEF WITHLAZARUSICONS} + Pic: TPicture; + {$ELSE} + Pic: TIcon; + {$ENDIF} + 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; +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 := $B00000; + end; + end else + result.Font.Height := FontHeight; + Text := CR(Text); + result.AutoSize := false; + R.Left := 0; + R.Top := 0; + W := aWidth-X-8; + R.Right := W; + R.Bottom := result.Height; + 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 (Ynil then + aParent := Screen.ActiveCustomForm.Handle else + aParent := 0; + Dialog.OnButtonClicked := aOnButtonClicked; + {$ifdef MSWINDOWS} + if Assigned(TaskDialogIndirect) and not aNonNative and + not (tdfQuery in aFlags) and (Selection='') then begin + Dialog.Emulated := False; + // use Vista/Seven TaskDialog implementation (not tdfQuery nor Selection) + FillChar(Config{%H-},sizeof(Config),0); + Config.cbSize := sizeof(Config); + Config.hwndParent := aParent; + Config.pszWindowTitle := PWideChar(N(Title)); + Config.pszMainInstruction := PWideChar(N(Inst)); + Config.pszContent := PWideChar(N(Content)); + RUCount := 0; + AddRU(Buttons,Config.cButtons,100); + AddRU(Radios,Config.cRadioButtons,200); + if Config.cButtons>0 then + Config.pButtons := @But[0]; + if Config.cRadioButtons>0 then + Config.pRadioButtons := @But[Config.cButtons]; + Config.pszVerificationText := PWideChar(N(Verify)); + Config.pszExpandedInformation := PWideChar(N(Info)); + Config.pszExpandedControlText := PWideChar(N(InfoExpanded)); + Config.pszCollapsedControlText := PWideChar(N(InfoCollapse)); + Config.pszFooter := PWideChar(N(Footer)); + Config.dwCommonButtons := byte(aCommonButtons); + if (Verify<>'') and VerifyChecked then + include(aFlags,tdfVerificationFlagChecked); + if (Config.cButtons=0) and (aCommonButtons=[cbOk]) then + Include(aFlags,tdfAllowDialogCancellation); // just OK -> Esc/Alt+F4 close + Config.dwFlags := integer(aFlags); + Config.hMainIcon := TD_ICONS[aDialogIcon]; + Config.hFooterIcon := TD_FOOTERICONS[aFooterIcon]; + Config.nDefaultButton := aButtonDef; + Config.nDefaultRadioButton := aRadioDef; + Config.cxWidth := aWidth; + Config.pfCallback := @TaskDialogCallbackProc; + Config.lpCallbackData := @self; + if TaskDialogIndirect(@Config,@result,@RadioRes,@VerifyChecked)=S_OK then + exit; // error (mostly invalid argument) -> execute the VCL emulation + end; + {$endif MSWINDOWS} + // use our native (naive?) Delphi implementation + Dialog.Emulated := true; + Dialog.Form := TEmulatedTaskDialog.CreateNew(Application); + try + Dialog.Form.Owner := @Self; + // initialize form properties + Dialog.Form.BorderStyle := bsDialog; + if tdfAllowDialogCancellation in aFlags then + Dialog.Form.BorderIcons := [biSystemMenu] + else + Dialog.Form.BorderIcons := []; + if tdfPositionRelativeToWindow in aFlags then + Dialog.Form.Position := poOwnerFormCenter + else + Dialog.Form.Position := poScreenCenter; + if not aEmulateClassicStyle then + Dialog.Form.Font := DefaultFont; + FontHeight := Dialog.Form.Font.Height; + if FontHeight = 0 then + FontHeight := Screen.SystemFont.Height; + if aWidth=0 then begin + aWidth := Dialog.Form.Canvas.TextWidth(Inst); + if (aWidth>300) or (Dialog.Form.Canvas.TextWidth(Content)>300) or + (length(Buttons)>40) then + aWidth := 480 else + aWidth := 420; + end; + Dialog.Form.ClientWidth := aWidth; + Dialog.Form.Height := 200; + Dialog.Form.Caption := Title; + // create a white panel for the main dialog part + Panel := TPanel.Create(Dialog.Form); + Panel.Parent := Dialog.Form; + Panel.Align := alTop; + Panel.BorderStyle := bsNone; + Panel.BevelOuter := bvNone; + if not aEmulateClassicStyle then begin + Panel.Color := clWhite; + end; + Par := Panel; + // handle main dialog icon + if aEmulateClassicStyle then + IconBorder := 10 else + IconBorder := 24; + + if + {$IFDEF WITHLAZARUSICONS} + LAZ_ICONS[aDialogIcon]<>'' + {$ELSE} + WIN_ICONS[aDialogIcon]<>nil + {$ENDIF} + then + begin + Image := TImage.Create(Dialog.Form); + Image.Parent := Par; + {$IFDEF WITHLAZARUSICONS} + Image.Picture.LoadFromResourceName(HINSTANCE, LAZ_ICONS[aDialogIcon]); + {$ELSE} + Image.Picture.Icon.Handle := LoadIcon(0,WIN_ICONS[aDialogIcon]); + {$ENDIF} + Image.SetBounds(IconBorder,IconBorder,Image.Picture.Icon.Width,Image.Picture.Icon.Height); + X := Image.Width+IconBorder*2; + Y := Image.Top; + if aEmulateClassicStyle then + inc(Y, 8); + end else + begin + Image := nil; + if not aEmulateClassicStyle then + IconBorder := IconBorder*2; + X := IconBorder; + Y := IconBorder; + end; + // add main texts (Instruction, Content, Information) + Dialog.Form.Element[tdeMainInstruction] := AddLabel(Inst,true); + Dialog.Form.Element[tdeContent] := AddLabel(Content, false); + if Info<>'' then + // no information collapse/expand yet: it's always expanded + Dialog.Form.Element[tdeExpandedInfo] := AddLabel(Info,false); + // add command links buttons + if (tdfUseCommandLinks in aFlags) and (Buttons<>'') then + with TStringList.Create do + try + inc(Y,8); + Text := SysUtils.trim(Buttons); + for i := 0 to Count-1 do begin + CommandLink := TBitBtn.Create(Dialog.Form); + with CommandLink do begin + Parent := Par; + Font.Height := FontHeight-3; + if aEmulateClassicStyle then + SetBounds(X,Y,aWidth-10-X,40) else + SetBounds(X,Y,aWidth-16-X,40); + Caption := NoCR(Strings[i]); + if aHint<>'' then begin + ShowHint := true; + Hint := aHint; // note shown as Hint + end; + inc(Y,Height+2); + ModalResult := i+100; + OnClick := Dialog.Form.HandleEmulatedButtonClicked; + if ModalResult=aButtonDef then + Dialog.Form.ActiveControl := CommandLink; + if aEmulateClassicStyle then begin + Font.Height := FontHeight - 2; + Font.Style := [fsBold] + end; + if aEmulateClassicStyle then begin + Margin := 7; + Spacing := 7; + end else begin + Margin := 24; + Spacing := 10; + end; + if not (tdfUseCommandLinksNoIcon in aFlags) then + begin + PngImg := TPortableNetworkGraphic.Create; + try + PngImg.LoadFromResourceName(HINSTANCE, 'btn_arrowright'); + Glyph.Assign(PngImg); + finally + PngImg.Free; + end; + end; + end; + end; + inc(Y,24); + finally + Free; + end; + // add radio buttons + if Radios<>'' then + with TStringList.Create do + try + Text := SysUtils.trim(Radios); + SetLength(Rad,Count); + for i := 0 to Count-1 do begin + Rad[i] := TRadioButton.Create(Dialog.Form); + with Rad[i] do begin + Parent := Par; + SetBounds(X+16,Y,aWidth-32-X,6-FontHeight); + Caption := NoCR(Strings[i]); + if aHint<>'' then begin + ShowHint := true; + Hint := aHint; // note shown as Hint + end; + inc(Y,Height); + if (i=0) or (i+200=aRadioDef) then + Checked := true; + end; + end; + inc(Y,24); + finally + Free; + end; + // add selection list or query editor + if Selection<>'' then begin + List := TStringList.Create; + try + Dialog.Form.Combo := TComboBox.Create(Dialog.Form); + with Dialog.Form.Combo do begin + Parent := Par; + SetBounds(X,Y,aWidth-32-X,22); + if tdfQuery in aFlags then + Style := csDropDown else + Style := csDropDownList; + List.Text := trim(Selection); + Items.Assign(List); + ItemIndex := List.IndexOf(Query); + if (ItemIndex=-1) and (Style=csDropDown) then + Text := Query; + if tdfQueryFieldFocused in aFlags then + Dialog.Form.ActiveControl := Dialog.Form.Combo; + end; + inc(Y,42); + finally + List.Free; + end; + end else + if tdfQuery in aFlags then begin + Dialog.Form.Edit := TEdit.Create(Dialog.Form); + with Dialog.Form.Edit do begin + Parent := Par; + SetBounds(X,Y,aWidth-16-X,22); + Text := Query; + if tdfQueryMasked in aFlags then + PasswordChar := '*'; + end; + if tdfQueryFieldFocused in aFlags then + Dialog.Form.ActiveControl := Dialog.Form.Edit; + inc(Y,42); + end; + // from now we won't add components to the white panel, but to the form + Panel.Height := Y; + Par := Dialog.Form; + // add buttons and verification checkbox + if (byte(aCommonButtons)<>0) or (Verify<>'') or + ((Buttons<>'') and not (tdfUseCommandLinks in aFlags)) then begin + CurrTabOrder := Panel.TabOrder; + inc(Y, 16); + XB := aWidth; + if not (tdfUseCommandLinks in aFlags) then + with TStringList.Create do + try + Text := SysUtils.trim(Buttons); + for i := Count-1 downto 0 do + AddButton(Strings[i],i+100); + finally + Free; + end; + for B := high(B) downto low(B) do + if B in aCommonButtons then + AddButton(TD_Trans(LoadResString(TD_BTNS(B))), TD_BTNMOD[B]); + if Verify<>'' then begin + Dialog.Form.Verif := TCheckBox.Create(Dialog.Form); + with Dialog.Form.Verif do begin + Parent := Par; + if X+16+Dialog.Form.Canvas.TextWidth(Verify)>XB then begin + inc(Y,32); + XB := aWidth; + end; + SetBounds(X,Y,XB-X,24); + Caption := Verify; + Checked := VerifyChecked; + end; + end; + inc(Y,36); + end else + XB := 0; + // add footer text with optional icon + if Footer<>'' then begin + if XB<>0 then + AddBevel else + inc(Y,16); + if + {$IFDEF WITHLAZARUSICONS} + LAZ_ICONS[aDialogIcon]<>'' + {$ELSE} + WIN_ICONS[aDialogIcon]<>nil + {$ENDIF} + then + begin + Image := TImage.Create(Dialog.Form); + Image.Parent := Par; + {$IFDEF WITHLAZARUSICONS} + Pic := TPicture.Create; + {$ELSE} + Pic := TIcon.Create; + {$ENDIF} + Bmp := TBitmap.Create; + try + Bmp.Transparent := true; + {$IFDEF WITHLAZARUSICONS} + Pic.LoadFromLazarusResource(LAZ_FOOTERICONS[aFooterIcon]); + {$ELSE} + Pic.Handle := LoadIcon(0,WIN_FOOTERICONS[aFooterIcon]); + {$ENDIF} + Bmp.Width := Pic.Width shr 1; + Bmp.Height := Pic.Height shr 1; + 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)); + {$IFDEF WITHLAZARUSICONS} + Bmp.Canvas.StretchDraw(Rect(0, 0, Bmp.Width, Bmp.Height), Pic.Graphic); + {$ELSE} + DrawIconEx(Bmp.Canvas.Handle,0,0,Pic.Handle,Bmp.Width,Bmp.Height,0, + Bmp.Canvas.Brush.{%H-}Handle,DI_NORMAL); + {$ENDIF} + Image.Picture.Bitmap := Bmp; + Image.SetBounds(24,Y,Bmp.Width,Bmp.Height); + X := 40+Bmp.Width; + finally + Bmp.Free; + Pic.Free; + end; + end else + begin + X := 24; + end; + Dialog.Form.Element[tdeFooter] := AddLabel(Footer,false); + end; + // display the form + Dialog.Form.ClientHeight := Y; + + //set form parent + 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 + Dialog.Form.PopupMode := pmExplicit; + + // retrieve the results + result := Dialog.Form.ShowModal; + if Dialog.Form.Combo<>nil then begin + SelectionRes := Dialog.Form.Combo.ItemIndex; + Query := Dialog.Form.Combo.Text; + end else + if Dialog.Form.Edit<>nil then + Query := Dialog.Form.Edit.Text; + if Dialog.Form.Verif<>nil then + VerifyChecked := Dialog.Form.Verif.Checked; + RadioRes := 0; + for i := 0 to high(Rad) do + if Rad[i].Checked then + RadioRes := i+200; + finally + FreeAndNil(Dialog.Form); + end; +end; + +procedure TTaskDialog.SetElementText(element: TTaskDialogElement; const Text: string); +{$IFDEF MSWINDOWS} +const // wParam = element (TASKDIALOG_ELEMENTS), lParam = new element text (LPCWSTR) + TDM_UPDATE_ELEMENT_TEXT = WM_USER+114; +{$ENDIF} +begin + case element of + tdeContent..tdeMainInstruction: + if Dialog.Emulated then + Dialog.Form.Element[element].Caption := CR(Text) + {$IFDEF MSWINDOWS} + else + SendMessageW(Dialog.Wnd,TDM_UPDATE_ELEMENT_TEXT,ord(element), + {%H-}NativeInt(PWideChar(_WS(Text)))) + {$ENDIF}; + tdeEdit: + if Dialog.Emulated then + Dialog.Form.Edit.Text := Text; // only in emulation + tdeVerif: + if Dialog.Emulated then + Dialog.Form.Verif.Caption := Text + end; +end; + + +{ TEmulatedTaskDialog } + +constructor TEmulatedTaskDialog.CreateNew(AOwner: TComponent; Num: Integer); +begin + inherited CreateNew(AOwner, Num); + + KeyPreview := True; +end; + +procedure TEmulatedTaskDialog.HandleEmulatedButtonClicked(Sender: TObject); +var btn: TButton absolute Sender; + CanClose: Boolean; +begin + if Assigned(Owner) and Assigned(Owner.Dialog.OnButtonClicked) then begin + CanClose := true; + Owner.Dialog.OnButtonClicked(Owner,btn.ModalResult,CanClose); + if not CanClose then + ModalResult := mrNone; + end; +end; + +procedure TEmulatedTaskDialog.KeyDown(var Key: Word; Shift: TShiftState); +begin + if (biSystemMenu in BorderIcons) then//is Alt+F4/Esc cancellation allowed? + begin//yes -> cancel on ESC + if Key = VK_ESCAPE then + Close; + end else + begin//no -> block Alt+F4 + 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; + end; + + inherited KeyDown(Key, Shift); +end; + + +{ TTaskDialogEx } + +procedure TTaskDialogEx.Init; +begin + self := DefaultTaskDialog; +end; + +function TTaskDialogEx.Execute(aParent: HWND): integer; +begin + Result := Base.Execute(CommonButtons, ButtonDef, Flags, DialogIcon, FooterIcon, + RadioDef, Width, aParent, NonNative, EmulateClassicStyle, OnButtonClicked); +end; + +initialization + DefaultFont := TFont.Create; + DefaultFont.Style := []; + if Screen.Fonts.IndexOf('Calibri')>=0 then begin + DefaultFont.Size := 11; + DefaultFont.Name := 'Calibri'; + end else begin + if Screen.Fonts.IndexOf('Tahoma')>=0 then + DefaultFont.Name := 'Tahoma' else + DefaultFont.Name := 'Arial'; + + {$IFDEF DARWIN} + DefaultFont.Size := 13; + {$ELSE} + DefaultFont.Size := 10; + {$ENDIF} + end; + {$IFDEF MSWINDOWS} + InitComCtl6; + {$ENDIF} + assert(ord(tdfCanBeMinimized)=15); + +finalization + DefaultFont.Free; + +end.