1{
2 /***************************************************************************
3                               dialogs.pp
4                               ----------
5                Component Library Standard dialogs Controls
6
7
8 ***************************************************************************/
9
10 *****************************************************************************
11  This file is part of the Lazarus Component Library (LCL)
12
13  See the file COPYING.modifiedLGPL.txt, included in this distribution,
14  for details about the license.
15 *****************************************************************************
16}
17unit Dialogs;
18
19{$mode objfpc}{$H+}
20
21interface
22
23uses
24  // RTL + FCL
25  Types, typinfo, Classes, SysUtils,
26  // LCL
27  LMessages, LResources, LCLIntf, InterfaceBase, LCLStrConsts, LCLType,
28  Forms, Controls, Themes, GraphType, Graphics, Buttons, ButtonPanel, StdCtrls,
29  ExtCtrls, LCLClasses, ClipBrd, Menus, LCLTaskDialog,
30  // LazUtils
31  UITypes, FileUtil, LazFileUtils, LazStringUtils, LazLoggerBase;
32
33type
34  // Aliases for types in UITypes.
35  TMsgDlgType    = UITypes.TMsgDlgType;
36  TMsgDlgBtn     = UITypes.TMsgDlgBtn;
37  TMsgDlgButtons = UITypes.TMsgDlgButtons;
38
39const
40  // Aliases for enum values in UITypes.
41  mtWarning      = UITypes.TMsgDlgType.mtWarning;
42  mtError        = UITypes.TMsgDlgType.mtError;
43  mtInformation  = UITypes.TMsgDlgType.mtInformation;
44  mtConfirmation = UITypes.TMsgDlgType.mtConfirmation;
45  mtCustom       = UITypes.TMsgDlgType.mtCustom;
46
47  mbYes      = UITypes.TMsgDlgBtn.mbYes;
48  mbNo       = UITypes.TMsgDlgBtn.mbNo;
49  mbOK       = UITypes.TMsgDlgBtn.mbOK;
50  mbCancel   = UITypes.TMsgDlgBtn.mbCancel;
51  mbAbort    = UITypes.TMsgDlgBtn.mbAbort;
52  mbRetry    = UITypes.TMsgDlgBtn.mbRetry;
53  mbIgnore   = UITypes.TMsgDlgBtn.mbIgnore;
54  mbAll      = UITypes.TMsgDlgBtn.mbAll;
55  mbNoToAll  = UITypes.TMsgDlgBtn.mbNoToAll;
56  mbYesToAll = UITypes.TMsgDlgBtn.mbYesToAll;
57  mbHelp     = UITypes.TMsgDlgBtn.mbHelp;
58  mbClose    = UITypes.TMsgDlgBtn.mbClose;
59
60  // Combinations of buttons.
61  mbYesNoCancel = [mbYes, mbNo, mbCancel];
62  mbYesNo = [mbYes, mbNo];
63  mbOKCancel = [mbOK, mbCancel];
64  mbAbortRetryIgnore = [mbAbort, mbRetry, mbIgnore];
65
66  MsgDlgBtnToBitBtnKind: array[TMsgDlgBtn] of TBitBtnKind = (
67    bkYes, bkNo, bkOK, bkCancel, bkAbort, bkRetry, bkIgnore,
68    bkAll, bkNoToAll, bkYesToAll, bkHelp, bkClose
69    );
70
71  BitBtnKindToMsgDlgBtn: array[TBitBtnKind] of TMsgDlgBtn = (
72    mbOk, mbOK, mbCancel, mbHelp, mbYes, mbNo,
73    mbClose, mbAbort, mbRetry, mbIgnore, mbAll, mbNoToALl, mbYesToAll
74    );
75
76type
77
78  { TCommonDialog }
79
80  TCDWSEventCapability = (cdecWSPerformsDoShow, cdecWSPerformsDoCanClose, cdecWSPerformsDoClose,
81                          cdecWSNOCanCloseSupport);
82  TCDWSEventCapabilities = set of TCDWSEventCapability;
83
84  TDialogResultEvent = procedure(sender: TObject; Success: boolean) of object;
85
86  TCommonDialog = class(TLCLComponent)
87  private
88    FAttachTo: TCustomForm;
89    FHandle : THandle;
90    FHeight: integer;
91    FOnDialogResult: TDialogResultEvent;
92    FWidth: integer;
93    FOnCanClose: TCloseQueryEvent;
94    FOnShow, FOnClose : TNotifyEvent;
95    FTitle : string;
96    FUserChoice: integer;
97    FHelpContext: THelpContext;
98    FDoCanCloseCalled: Boolean;
99    FDoShowCalled: Boolean;
100    FDoCloseCalled: Boolean;
101    FClosing: boolean;
102    FWSEventCapabilities :TCDWSEventCapabilities;
103    procedure SetHandle(const AValue: THandle);
104    function IsTitleStored: boolean;
105  protected
106    class procedure WSRegisterClass; override;
107    function DoExecute : boolean; virtual;
108    function DefaultTitle: string; virtual;
109    function GetHeight: Integer; virtual;
110    function GetWidth: Integer; virtual;
111    procedure SetHeight(const AValue: integer); virtual;
112    procedure SetWidth(const AValue: integer); virtual;
113    procedure ResetShowCloseFlags;
114    property AttachTo: TCustomForm read FAttachTo write FAttachTo; platform;
115    property OnDialogResult:TDialogResultEvent read FOnDialogResult write FOnDialogResult; platform;
116  public
117    FCompStyle : LongInt;
118    constructor Create(TheOwner: TComponent); override;
119    function Execute: boolean; virtual;
120    property Handle: THandle read FHandle write SetHandle;
121    property UserChoice: integer read FUserChoice write FUserChoice;
122    procedure Close; virtual;
123    procedure DoShow; virtual;
124    procedure DoCanClose(var CanClose: Boolean); virtual;
125    procedure DoClose; virtual;
126    function HandleAllocated: boolean;
127    property Width: integer read GetWidth write SetWidth;
128    property Height: integer read GetHeight write SetHeight;
129  published
130    property OnClose: TNotifyEvent read FOnClose write FOnClose;
131    property OnCanClose: TCloseQueryEvent read FOnCanClose write FOnCanClose;
132    property OnShow: TNotifyEvent read FOnShow write FOnShow;
133    property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
134    property Title: TTranslateString read FTitle write FTitle stored IsTitleStored;
135  end;
136
137
138  { TFileDialog }
139
140  TFileDialog = class(TCommonDialog)
141  private
142    FInternalFilterIndex: Integer;
143    FDefaultExt: string;
144    FFileName : String;
145    FFiles: TStrings;
146    FFilter: String;
147    FFilterIndex: Integer;
148    FHistoryList: TStrings;
149    FInitialDir: string;
150    FOnHelpClicked: TNotifyEvent;
151    FOnTypeChange: TNotifyEvent;
152    procedure SetDefaultExt(const AValue: string);
153    procedure SetFilterIndex(const AValue: Integer);
154  protected
155    class procedure WSRegisterClass; override;
156    function GetFilterIndex: Integer; virtual;
157    procedure SetFileName(const Value: String); virtual;
158    procedure SetFilter(const Value: String); virtual;
159    procedure SetHistoryList(const AValue: TStrings); virtual;
160  public
161    constructor Create(TheOwner: TComponent); override;
162    destructor Destroy; override;
163    procedure DoCanClose(var CanClose: Boolean); override;
164    procedure DoTypeChange; virtual;
165    property Files: TStrings read FFiles;
166    property HistoryList: TStrings read FHistoryList write SetHistoryList;
167    procedure IntfFileTypeChanged(NewFilterIndex: Integer);
168    class function FindMaskInFilter(aFilter, aMask: string): integer;
169    class function ExtractAllFilterMasks(aFilter: string;
170                                   SkipAllFilesMask: boolean = true): string;
171  published
172    property Title;
173    property DefaultExt: string read FDefaultExt write SetDefaultExt;
174    property FileName: String read FFileName write SetFileName;
175    property Filter: String read FFilter write SetFilter;
176    property FilterIndex: Integer read GetFilterIndex write SetFilterIndex default 1;
177    property InitialDir: string read FInitialDir write FInitialDir;
178    property OnHelpClicked: TNotifyEvent read FOnHelpClicked write FOnHelpClicked;
179    property OnTypeChange: TNotifyEvent read FOnTypeChange write FOnTypeChange;
180  end;
181
182
183  { TOpenDialog }
184
185  TOpenOption = (
186    ofReadOnly,
187    ofOverwritePrompt, // if selected file exists shows a message, that file
188                       // will be overwritten
189    ofHideReadOnly,    // hide read only file
190    ofNoChangeDir,     // do not change current directory
191    ofShowHelp,        // show a help button
192    ofNoValidate,
193    ofAllowMultiSelect,// allow multiselection
194    ofExtensionDifferent,
195    ofPathMustExist,   // shows an error message if selected path does not exist
196    ofFileMustExist,   // shows an error message if selected file does not exist
197    ofCreatePrompt,
198    ofShareAware,
199    ofNoReadOnlyReturn,// do not return filenames that are readonly
200    ofNoTestFileCreate,
201    ofNoNetworkButton,
202    ofNoLongNames,
203    ofOldStyleDialog,
204    ofNoDereferenceLinks,// do not resolve links while dialog is shown (only on Windows, see OFN_NODEREFERENCELINKS)
205    ofNoResolveLinks,  // do not resolve links after Execute
206    ofEnableIncludeNotify,
207    ofEnableSizing,    // dialog can be resized, e.g. via the mouse
208    ofDontAddToRecent, // do not add the path to the history list
209    ofForceShowHidden, // show hidden files
210    ofViewDetail,      // details are OS and interface dependent
211    ofAutoPreview      // details are OS and interface dependent
212    );
213  TOpenOptions = set of TOpenOption;
214
215const
216  DefaultOpenDialogOptions = [ofEnableSizing, ofViewDetail];
217
218type
219
220  TOpenDialog = class(TFileDialog)
221  private
222    FOnFolderChange: TNotifyEvent;
223    FOnSelectionChange: TNotifyEvent;
224    FOptions: TOpenOptions;
225    FLastSelectionChangeFilename: string;
226  protected
227    class procedure WSRegisterClass; override;
228    procedure ResolveLinks; virtual;
229    procedure DereferenceLinks; virtual; deprecated 'override ResolveLinks instead' {Laz 1.9};
230    function CheckFile(var AFilename: string): boolean; virtual;
231    function CheckFileMustExist(const AFileName: string): boolean; virtual;
232    function CheckAllFiles: boolean; virtual;
233    function DoExecute: boolean; override;
234    function DefaultTitle: string; override;
235  public
236    constructor Create(TheOwner: TComponent); override;
237    procedure DoCanClose(var CanClose: Boolean); override;
238    procedure DoFolderChange; virtual;
239    procedure DoSelectionChange; virtual;
240    procedure IntfSetOption(const AOption: TOpenOption; const AValue: Boolean);
241  published
242    property Options: TOpenOptions read FOptions write FOptions default DefaultOpenDialogOptions;
243    property OnFolderChange: TNotifyEvent read FOnFolderChange write FOnFolderChange;
244    property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;
245  end;
246
247
248  { TSaveDialog }
249
250  TSaveDialog = class(TOpenDialog)
251  protected
252    class procedure WSRegisterClass; override;
253    function DefaultTitle: string; override;
254  public
255    constructor Create(AOwner: TComponent); override;
256  end;
257
258
259  { TSelectDirectoryDialog }
260
261  TSelectDirectoryDialog = class(TOpenDialog)
262  protected
263    class procedure WSRegisterClass; override;
264    function CheckFileMustExist(const AFilename: string): boolean; override;
265    function DefaultTitle: string; override;
266  public
267    constructor Create(AOwner: TComponent); override;
268  end;
269
270  { TColorDialog }
271
272  TColorDialog = class(TCommonDialog)
273  private
274    FColor: TColor;
275    FCustomColors: TStrings;
276    procedure SetCustomColors(const AValue: TStrings);
277    procedure AddDefaultColor(const s: AnsiString);
278  protected
279    class procedure WSRegisterClass; override;
280    function DefaultTitle: string; override;
281  public
282    constructor Create(TheOwner: TComponent); override;
283    destructor Destroy; override;
284  published
285    property Title;
286    property Color: TColor read FColor write FColor;
287    // entry looks like ColorA = FFFF00 ... ColorX = C0C0C0
288    property CustomColors: TStrings read FCustomColors write SetCustomColors;
289  end;
290
291
292  { TColorButton }
293
294  TColorButton = class(TCustomSpeedButton)
295  private
296    FBorderWidth: Integer;
297    FButtonColorAutoSize: Boolean;
298    FButtonColorSize: Integer;
299    FButtonColor: TColor;
300    FColorDialog: TColorDialog;
301    FOnColorChanged: TNotifyEvent;
302    FDisabledPattern: TBitmap;
303    function IsButtonColorAutoSizeStored: boolean;
304    procedure SetBorderWidth(const AValue: Integer);
305    procedure SetButtonColor(const AValue: TColor);
306    procedure SetButtonColorAutoSize(const AValue: Boolean);
307    procedure SetButtonColorSize(const AValue: Integer);
308  protected
309    class procedure WSRegisterClass; override;
310    function DrawGlyph(ACanvas: TCanvas; const AClient: TRect; const AOffset: TPoint;
311      AState: TButtonState; ATransparent: Boolean; BiDiFlags: Longint): TRect; override;
312    function GetDisabledPattern: TBitmap; virtual;
313    function GetGlyphSize(Drawing: boolean; PaintRect: TRect): TSize; override;
314    class function GetControlClassDefaultSize: TSize; override;
315    procedure ShowColorDialog; virtual;
316  public
317    constructor Create(AnOwner: TComponent); override;
318    destructor Destroy; Override;
319    procedure Click; override;
320  published
321    property Action;
322    property Align;
323    property Anchors;
324    property AllowAllUp;
325    property BorderSpacing;
326    property BorderWidth: Integer read FBorderWidth write SetBorderWidth;
327    property ButtonColorAutoSize: Boolean read FButtonColorAutoSize
328                                          write SetButtonColorAutoSize
329                                          stored IsButtonColorAutoSizeStored;
330    property ButtonColorSize: Integer read FButtonColorSize write SetButtonColorSize;
331    property ButtonColor: TColor read FButtonColor write SetButtonColor;
332    property ColorDialog: TColorDialog read FColorDialog write FColorDialog;
333    property Constraints;
334    property Caption;
335    property Color;
336    property Down;
337    property Enabled;
338    property Flat;
339    property Font;
340    property GroupIndex;
341    property Hint;
342    property Layout;
343    property Margin;
344    property Spacing;
345    property Transparent;
346    property Visible;
347    property OnClick;
348    property OnColorChanged: TNotifyEvent read FOnColorChanged
349                                          write FOnColorChanged;
350    property OnDblClick;
351    property OnMouseDown;
352    property OnMouseEnter;
353    property OnMouseLeave;
354    property OnMouseMove;
355    property OnMouseUp;
356    property OnMouseWheel;
357    property OnMouseWheelDown;
358    property OnMouseWheelUp;
359    property OnPaint;
360    property OnResize;
361    property OnChangeBounds;
362    property ShowHint;
363    property ParentFont;
364    property ParentShowHint;
365    property PopupMenu;
366  end;
367
368
369  { TFontDialog }
370
371  TFontDialogOption = (fdAnsiOnly, fdTrueTypeOnly, fdEffects,
372    fdFixedPitchOnly, fdForceFontExist, fdNoFaceSel, fdNoOEMFonts,
373    fdNoSimulations, fdNoSizeSel, fdNoStyleSel,  fdNoVectorFonts,
374    fdShowHelp, fdWysiwyg, fdLimitSize, fdScalableOnly, fdApplyButton);
375  TFontDialogOptions = set of TFontDialogOption;
376
377  TFontDialog = class(TCommonDialog)
378  private
379    FFont: TFont;
380    FMaxFontSize: Integer;
381    FMinFontSize: Integer;
382    FOnApplyClicked: TNotifyEvent;
383    FOptions: TFontDialogOptions;
384    FPreviewText: string;
385    procedure SetFont(const AValue: TFont);
386  protected
387    class procedure WSRegisterClass; override;
388    function DefaultTitle: string; override;
389  public
390    procedure ApplyClicked; virtual;
391    constructor Create (AOwner : TComponent); override;
392    destructor Destroy; override;
393  published
394    property Title;
395    property Font: TFont read FFont write SetFont;
396    property MinFontSize: Integer read FMinFontSize write FMinFontSize;
397    property MaxFontSize: Integer read FMaxFontSize write FMaxFontSize;
398    property Options: TFontDialogOptions
399      read FOptions write FOptions default [fdEffects];
400    property OnApplyClicked: TNotifyEvent
401      read FOnApplyClicked write FOnApplyClicked;
402    property PreviewText: string read FPreviewText write FPreviewText;
403  end;
404
405
406{ TFindDialog }
407
408  TFindOption = (frDown, frFindNext, frHideMatchCase, frHideWholeWord,
409                 frHideUpDown, frMatchCase, frDisableMatchCase, frDisableUpDown,
410                 frDisableWholeWord, frReplace, frReplaceAll, frWholeWord, frShowHelp,
411                 frEntireScope, frHideEntireScope, frPromptOnReplace, frHidePromptOnReplace,
412                 frButtonsAtBottom);
413  TFindOptions = set of TFindOption;
414
415  TFindDialog = class(TCommonDialog)
416  private
417    FFormLeft: integer;
418    FFormTop: integer;
419    function GetReplaceText: string;
420    function GetFindText: string;
421    function GetLeft: Integer;
422    function GetPosition: TPoint;
423    function GetTop: Integer;
424    procedure SetFindText(const AValue: string);
425    procedure SetLeft(const AValue: Integer);
426    procedure SetOptions(AValue: TFindOptions);
427    procedure SetPosition(const AValue: TPoint);
428    procedure SetTop(const AValue: Integer);
429    procedure SetReplaceText(const AValue: string);
430  protected
431    FFindForm: TForm;
432    FOnReplace: TNotifyEvent;
433    FOnFind: TNotifyEvent;
434    FOptions: TFindOptions;
435    FOnHelpClicked: TNotifyEvent;
436    FReplaceText: string;
437    FFindText: string;
438
439    function DefaultTitle: string; override;
440
441    procedure FindClick(Sender: TObject);
442    procedure HelpClick(Sender: TObject);
443    procedure CancelClick(Sender: TObject);
444
445    function GetHeight: Integer; override;
446    function GetWidth: Integer; override;
447    procedure DoCloseForm(Sender: TObject; var CloseAction: TCloseAction);virtual;
448    procedure DoShowForm(Sender: TObject);virtual;
449    procedure Find; virtual;
450    procedure Help; virtual;
451    procedure Replace; virtual;
452    function CreateForm:TForm;virtual;
453    procedure SetFormValues;virtual;
454    procedure GetFormValues; virtual;
455    Procedure CalcPosition(aForm:Tform);
456    property ReplaceText: string read GetReplaceText write SetReplaceText;
457    property OnReplace: TNotifyEvent read FOnReplace write FOnReplace;
458  public
459    constructor Create(AOwner: TComponent); override;
460    destructor Destroy; override;
461    procedure CloseDialog;
462    function Execute: Boolean; override;
463    property Left: Integer read GetLeft write SetLeft;
464    property Position: TPoint read GetPosition write SetPosition;
465    property Top: Integer read GetTop write SetTop;
466  published
467    property FindText: string read GetFindText write SetFindText;
468    property Options: TFindOptions read FOptions write SetOptions default [frDown];
469    property OnFind: TNotifyEvent read FOnFind write FOnFind;
470    property OnHelpClicked: TNotifyEvent read FOnHelpClicked write FOnHelpClicked;
471  end;
472
473
474{ TReplaceDialog }
475
476  TReplaceDialog = class(TFindDialog)
477  protected
478    function DefaultTitle: string; override;
479    procedure ReplaceClick(Sender: TObject);
480    procedure ReplaceAllClick(Sender: TObject);
481    function CreateForm: TForm; override;
482    procedure SetFormValues; override;
483    procedure GetFormValues; override;
484  public
485    constructor Create(AOwner: TComponent); override;
486  published
487    property ReplaceText;
488    property OnReplace;
489  end;
490
491
492
493{ TPrinterSetupDialog }
494
495  TCustomPrinterSetupDialog = class(TCommonDialog)
496  end;
497
498
499{ TPrintDialog }
500
501  TPrintRange = (prAllPages, prSelection, prPageNums, prCurrentPage);
502  TPrintDialogOption = (poPrintToFile, poPageNums, poSelection, poWarning,
503    poHelp, poDisablePrintToFile, poBeforeBeginDoc);
504  TPrintDialogOptions = set of TPrintDialogOption;
505
506  TCustomPrintDialog = class(TCommonDialog)
507  private
508    FFromPage: Integer;
509    FToPage: Integer;
510    FCollate: Boolean;
511    FOptions: TPrintDialogOptions;
512    FPrintToFile: Boolean;
513    FPrintRange: TPrintRange;
514    FMinPage: Integer;
515    FMaxPage: Integer;
516    FCopies: Integer;
517  public
518    constructor Create(TheOwner: TComponent); override;
519  public
520    property Collate: Boolean read FCollate write FCollate default False;
521    property Copies: Integer read FCopies write FCopies default 1;
522    property FromPage: Integer read FFromPage write FFromPage default 0;
523    property MinPage: Integer read FMinPage write FMinPage default 0;
524    property MaxPage: Integer read FMaxPage write FMaxPage default 0;
525    property Options: TPrintDialogOptions read FOptions write FOptions default [];
526    property PrintToFile: Boolean read FPrintToFile write FPrintToFile default False;
527    property PrintRange: TPrintRange read FPrintRange write FPrintRange default prAllPages;
528    property ToPage: Integer read FToPage write FToPage default 0;
529  end;
530
531{ TTaskDialog }
532
533type
534  TCustomTaskDialog = class;
535
536  TTaskDialogFlag = (tfEnableHyperlinks, tfUseHiconMain,
537    tfUseHiconFooter, tfAllowDialogCancellation,
538    tfUseCommandLinks, tfUseCommandLinksNoIcon,
539    tfExpandFooterArea, tfExpandedByDefault,
540    tfVerificationFlagChecked, tfShowProgressBar,
541    tfShowMarqueeProgressBar, tfCallbackTimer,
542    tfPositionRelativeToWindow, tfRtlLayout,
543    tfNoDefaultRadioButton, tfCanBeMinimized);
544  TTaskDialogFlags = set of TTaskDialogFlag;
545
546  TTaskDialogCommonButton = (tcbOk, tcbYes, tcbNo, tcbCancel, tcbRetry, tcbClose);
547  TTaskDialogCommonButtons = set of TTaskDialogCommonButton;
548
549  TTaskDlgClickEvent = procedure(Sender: TObject; AModalResult: TModalResult; var ACanClose: Boolean) of object;
550
551  TTaskDialogIcon = (tdiNone, tdiWarning, tdiError, tdiInformation, tdiShield, tdiQuestion);
552
553  TTaskDialogButtons = class;
554
555  TTaskDialogBaseButtonItem = class(TCollectionItem)
556  private
557    FCaption: TTranslateString;
558    FClient: TCustomTaskDialog;
559    FModalResult: TModalResult;
560    function GetDefault: Boolean;
561    procedure SetCaption(const ACaption: TTranslateString);
562    procedure SetDefault(const Value: Boolean);
563  protected
564    property Client: TCustomTaskDialog read FClient;
565    function GetDisplayName: TTranslateString; override;
566    function TaskButtonCollection: TTaskDialogButtons;
567  public
568    constructor Create(ACollection: TCollection); override;
569    property ModalResult: TModalResult read FModalResult write FModalResult;
570  published
571    property Caption: TTranslateString read FCaption write SetCaption;
572    property Default: Boolean read GetDefault write SetDefault default False;
573  end;
574
575  TTaskDialogButtonItem = class(TTaskDialogBaseButtonItem)
576  public
577    constructor Create(ACollection: TCollection); override;
578  published
579    property ModalResult;
580  end;
581
582  TTaskDialogRadioButtonItem = class(TTaskDialogBaseButtonItem)
583  public
584    constructor Create(ACollection: TCollection); override;
585  end;
586
587  TTaskDialogButtonsEnumerator = class
588  private
589    FIndex: Integer;
590    FCollection: TTaskDialogButtons;
591  public
592    constructor Create(ACollection: TTaskDialogButtons);
593    function GetCurrent: TTaskDialogBaseButtonItem;
594    function MoveNext: Boolean;
595    property Current: TTaskDialogBaseButtonItem read GetCurrent;
596  end;
597
598  TTaskDialogButtons = class(TOwnedCollection)
599  private
600    FDefaultButton: TTaskDialogBaseButtonItem;
601    function GetItem(Index: Integer): TTaskDialogBaseButtonItem;
602    procedure SetDefaultButton(const Value: TTaskDialogBaseButtonItem);
603    procedure SetItem(Index: Integer; const Value: TTaskDialogBaseButtonItem);
604  public
605    function Add: TTaskDialogBaseButtonItem;
606    function FindButton(AModalResult: TModalResult): TTaskDialogBaseButtonItem;
607    function GetEnumerator: TTaskDialogButtonsEnumerator;
608    property DefaultButton: TTaskDialogBaseButtonItem read FDefaultButton write SetDefaultButton;
609    property Items[Index: Integer]: TTaskDialogBaseButtonItem read GetItem write SetItem; default;
610  end;
611
612  TCustomTaskDialog = class(TComponent)
613  private
614    FButton: TTaskDialogButtonItem;
615    FButtons: TTaskDialogButtons;
616    FCaption: TTranslateString;
617    FCommonButtons: TTaskDialogCommonButtons;
618    FDefaultButton: TTaskDialogCommonButton;
619    FExpandButtonCaption: TTranslateString;
620    FExpandedText: TTranslateString;
621    FFlags: TTaskDialogFlags;
622    FFooterIcon: TTaskDialogIcon;
623    FFooterText: TTranslateString;
624    FMainIcon: TTaskDialogIcon;
625    FModalResult: TModalResult;
626    FRadioButton: TTaskDialogRadioButtonItem;
627    FRadioButtons: TTaskDialogButtons;
628    FText: TTranslateString;
629    FTitle: TTranslateString;
630    FVerificationText: TTranslateString;
631    FOnButtonClicked: TTaskDlgClickEvent;
632    procedure DoOnButtonClickedHandler(Sender: PTaskDialog; AButtonID: integer;
633      var ACanClose: Boolean);
634    procedure SetButtons(const Value: TTaskDialogButtons);
635    procedure SetRadioButtons(const Value: TTaskDialogButtons);
636    function ButtonIDToModalResult(const AButtonID: Integer): TModalResult;
637  protected
638    function DoExecute(ParentWnd: HWND): Boolean; dynamic;
639    procedure DoOnButtonClicked(AModalResult: Integer; var ACanClose: Boolean); dynamic;
640  public
641    constructor Create(AOwner: TComponent); override;
642    destructor Destroy; override;
643    function Execute: Boolean; overload; dynamic;
644    function Execute(ParentWnd: HWND): Boolean; overload; dynamic;
645    property Button: TTaskDialogButtonItem read FButton write FButton;
646    property Buttons: TTaskDialogButtons read FButtons write SetButtons;
647    property Caption: TTranslateString read FCaption write FCaption;
648    property CommonButtons: TTaskDialogCommonButtons read FCommonButtons write FCommonButtons default [tcbOk, tcbCancel];
649    property DefaultButton: TTaskDialogCommonButton read FDefaultButton write FDefaultButton default tcbOk;
650    property ExpandButtonCaption: TTranslateString read FExpandButtonCaption write FExpandButtonCaption;
651    property ExpandedText: TTranslateString read FExpandedText write FExpandedText;
652    property Flags: TTaskDialogFlags read FFlags write FFlags default [tfAllowDialogCancellation];
653    property FooterIcon: TTaskDialogIcon read FFooterIcon write FFooterIcon default tdiNone;
654    property FooterText: TTranslateString read FFooterText write FFooterText;
655    property MainIcon: TTaskDialogIcon read FMainIcon write FMainIcon default tdiInformation;
656    property ModalResult: TModalResult read FModalResult write FModalResult;
657    property RadioButton: TTaskDialogRadioButtonItem read FRadioButton;
658    property RadioButtons: TTaskDialogButtons read FRadioButtons write SetRadioButtons;
659    property Text: TTranslateString read FText write FText;
660    property Title: TTranslateString read FTitle write FTitle;
661    property VerificationText: TTranslateString read FVerificationText write FVerificationText;
662    property OnButtonClicked: TTaskDlgClickEvent read FOnButtonClicked write FOnButtonClicked;
663  end;
664
665  TTaskDialog = class(TCustomTaskDialog)
666  published
667    property Buttons;
668    property Caption;
669    property CommonButtons;
670    property DefaultButton;
671    property ExpandButtonCaption;
672    property ExpandedText;
673    property Flags;
674    property FooterIcon;
675    property FooterText;
676    property MainIcon;
677    property RadioButtons;
678    property Text;
679    property Title;
680    property VerificationText;
681    property OnButtonClicked;
682  end;
683
684
685var
686  MinimumDialogButtonWidth: integer = 75;
687  MinimumDialogButtonHeight: integer = 25;
688
689{ MessageDlg }
690
691function MessageDlg(const aMsg: string; DlgType: TMsgDlgType;
692            Buttons: TMsgDlgButtons; HelpCtx: Longint): TModalResult; overload;
693function MessageDlg(const aCaption, aMsg: string; DlgType: TMsgDlgType;
694            Buttons: TMsgDlgButtons; HelpCtx: Longint): TModalResult; overload;
695function MessageDlg(const aCaption, aMsg: string; DlgType: TMsgDlgType;
696            Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): TModalResult; overload;
697function MessageDlg(const aMsg: string; DlgType: TMsgDlgType;
698            Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton: TMsgDlgBtn): TModalResult; overload;
699function MessageDlg(const aCaption, aMsg: string; DlgType: TMsgDlgType;
700            Buttons: TMsgDlgButtons; const HelpKeyword: string): TModalResult; overload;
701function MessageDlgPos(const aMsg: string; DlgType: TMsgDlgType;
702            Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): TModalResult; overload;
703function MessageDlgPosHelp(const aMsg: string; DlgType: TMsgDlgType;
704            Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
705            const HelpFileName: string): TModalResult; overload;
706function CreateMessageDialog(const aMsg: string; DlgType: TMsgDlgType;
707            Buttons: TMsgDlgButtons): TForm; overload;
708function CreateMessageDialog(const aCaption, aMsg: string; DlgType: TMsgDlgType;
709            Buttons: TMsgDlgButtons): TForm; overload;
710function DefaultPromptDialog(const DialogCaption,
711  DialogMessage: String;
712  DialogType: longint; Buttons: PLongint;
713  ButtonCount, DefaultIndex, EscapeResult: Longint;
714  UseDefaultPos: boolean;
715  X, Y: Longint): Longint;// widgetset independent implementation, see PromptDialogFunction
716
717function QuestionDlg(const aCaption, aMsg: string; DlgType: TMsgDlgType;
718            Buttons: array of const; HelpCtx: Longint): TModalResult; overload;
719function QuestionDlg(const aCaption, aMsg: string; DlgType: TMsgDlgType;
720            Buttons: array of const; const HelpKeyword: string): TModalResult; overload;
721function DefaultQuestionDialog(const aCaption, aMsg: string; DlgType: LongInt;
722  Buttons: TDialogButtons; HelpCtx: Longint): LongInt;// widgetset independent implementation, see QuestionDialogFunction
723
724procedure ShowMessage(const aMsg: string);
725procedure ShowMessageFmt(const aMsg: string; Params: array of const);
726procedure ShowMessagePos(const aMsg: string; X, Y: Integer);
727function DefaultMessageBox(Text, Caption: PChar; Flags: Longint) : Integer;// widgetset independent implementation, see MessageBoxFunction
728
729function InputBox(const ACaption, APrompt, ADefault : String) : String;
730function PasswordBox(const ACaption, APrompt : String) : String;
731
732type
733  TCustomCopyToClipboardDialog = class(TForm)
734  protected
735    procedure DoCreate; override;
736  public
737    function GetMessageText: string; virtual; abstract;
738  end;
739
740procedure RegisterDialogForCopyToClipboard(const ADlg: TCustomForm);
741procedure DialogCopyToClipboard(Self, Sender: TObject; var Key: Word; Shift: TShiftState);
742
743const
744  cInputQueryEditSizePixels: integer = 260; // Edit size in pixels
745  cInputQueryEditSizePercents: integer = 25; // Edit size in % of monitor width
746  cInputQuerySpacingSize: integer = 6;
747
748type
749  TSelectDirOpt = (sdAllowCreate, sdPerformCreate, sdPrompt);
750  TSelectDirOpts = set of TSelectDirOpt;
751  TInputCloseQueryEvent = procedure(Sender: TObject; const AValues: array of string;
752    var ACanClose: boolean) of object;
753
754function SelectDirectory(const Caption, InitialDirectory: string;
755  out Directory: string): boolean;
756function SelectDirectory(const Caption, InitialDirectory: string;
757  out Directory: string; ShowHidden: boolean; HelpCtx: Longint = 0): boolean;
758function SelectDirectory(out Directory: string;
759  Options: TSelectDirOpts; HelpCtx: Longint): Boolean;
760
761function InputQuery(const ACaption, APrompt : String; MaskInput : Boolean; var Value : String) : Boolean;
762function InputQuery(const ACaption, APrompt : String; var Value : String) : Boolean;
763function InputQuery(const ACaption: string; const APrompts: array of string;
764  var AValues: array of string; ACloseEvent: TInputCloseQueryEvent = nil): boolean;
765function DefaultInputDialog(const InputCaption, InputPrompt : String;
766  MaskInput : Boolean; var Value : String) : Boolean;// widgetset independent implementation, see InputDialogFunction
767
768function InputCombo(const ACaption, APrompt: string; const AList: TStrings): Integer;
769function InputCombo(const ACaption, APrompt: string; const AList : Array of String): Integer;
770function InputComboEx(const ACaption, APrompt: string; const AList: TStrings; AllowCustomText: Boolean = False): String;
771function InputComboEx(const ACaption, APrompt: string; const AList : Array of String; AllowCustomText: Boolean = False): String;
772
773function ExtractColorIndexAndColor(const AColorList: TStrings; const AIndex: Integer;
774  out ColorIndex: Integer; out ColorValue: TColor): Boolean;
775
776// helper functions (search LCLType for idDiag)
777function GetDialogCaption(idDiag: Integer): String;
778function GetDialogIcon(idDiag: Integer): TCustomBitmap;
779
780function dbgs(Option: TOpenOption): string; overload;
781function dbgs(Options: TOpenOptions): string; overload;
782
783procedure Register;
784
785implementation
786
787{$R dialog_icons.res}
788{ $R forms/finddlgunit.lfm}
789{ $R forms/replacedlgunit.lfm}
790
791uses
792  Math, WSDialogs;
793
794const
795  //
796  //TODO: all the constants below should be replaced in the future
797  //      their only purpose is to overcome some current design flaws &
798  //      missing features in the GTK libraries
799  //
800  cBitmapX  = 10;      // x-position for bitmap in messagedialog
801  cBitmapY  = 10;      // y-position for bitmap in messagedialog
802  cLabelSpacing = 10;   // distance between icon & label
803
804  DialogResult : Array[mrNone..mrLast] of Longint = (
805    -1, idButtonOK, idButtonCancel, idButtonAbort, idButtonRetry,
806    idButtonIgnore, idButtonYes,idButtonNo, idButtonAll, idButtonNoToAll,
807    idButtonYesToAll,idButtonClose);
808
809
810  DialogButtonKind : Array[idButtonOK..idButtonNoToAll] of TBitBtnKind = (
811    bkOk, bkCancel, bkHelp, bkYes, bkNo, bkClose, bkAbort, bkRetry,
812    bkIgnore, bkAll, bkYesToAll, bkNoToAll);
813
814  DialogResName: array[idDialogWarning..idDialogConfirm] of String =
815  (
816{idDialogWarning} 'dialog_warning',
817{idDialogError  } 'dialog_error',
818{idDialogInfo   } 'dialog_information',
819{idDialogConfirm} 'dialog_confirmation'
820  );
821
822type
823  TBitBtnAccess = class(TBitBtn);
824
825function dbgs(Option: TOpenOption): string;
826begin
827  Result:=GetEnumName(typeinfo(TOpenOption),ord(Option));
828end;
829
830function dbgs(Options: TOpenOptions): string;
831var
832  o: TOpenOption;
833begin
834  Result:='';
835  for o in Options do
836    Result:=Result+dbgs(o)+',';
837  Result:='['+LeftStr(Result,length(Result)-1)+']';
838end;
839
840procedure Register;
841begin
842  RegisterComponents('Dialogs',[TOpenDialog,TSaveDialog,TSelectDirectoryDialog,
843                                TColorDialog,TFontDialog,
844                                TFindDialog,TReplaceDialog, TTaskDialog]);
845  RegisterComponents('Misc',[TColorButton]);
846end;
847
848function DefaultMessageBox(Text, Caption: PChar; Flags: Longint) : Integer;
849var
850  DlgType : TMsgDlgType;
851  Buttons : TMsgDlgButtons;
852  CurBtn, DefButton: TMsgDlgBtn;
853  DefButtonIndex: Integer;
854begin
855  //This uses TMessageBox class in MessageDialogs.inc
856  if (Flags and MB_RETRYCANCEL) = MB_RETRYCANCEL then
857    Buttons := [mbRetry, mbCancel]
858  else
859  if (Flags and MB_YESNO) = MB_YESNO then
860    Buttons := [mbYes, mbNo]
861  else
862  if (Flags and MB_YESNOCANCEL) = MB_YESNOCANCEL then
863    Buttons := [mbYes, mbNo, mbCancel]
864  else
865  if (Flags and MB_ABORTRETRYIGNORE) = MB_ABORTRETRYIGNORE then
866    Buttons := [mbAbort, mbRetry, mbIgnore]
867  else
868  if (Flags and MB_OKCANCEL) = MB_OKCANCEL then
869    Buttons := [mbOK,mbCancel]
870  //else
871  //if (Flags and MB_OK) = MB_OK then  <-- MB_OK = 0, the test would always be true.
872  //  Buttons := [mbOK]
873  else
874    Buttons := [mbOK];
875
876  if (Flags and MB_ICONINFORMATION) = MB_ICONINFORMATION then
877    DlgTYpe := mtInformation
878  else
879  if (Flags and MB_ICONWARNING) = MB_ICONWARNING then
880    DlgTYpe := mtWarning
881  else
882  if (Flags and MB_ICONQUESTION) = MB_ICONQUESTION then
883    DlgTYpe := mtConfirmation
884  else
885  if (Flags and MB_ICONERROR) = MB_ICONERROR then
886    DlgTYpe := mtError
887  else
888    DlgTYpe := mtCustom;
889
890  if (Flags and MB_DEFBUTTON2) = MB_DEFBUTTON2 then
891    DefButtonIndex := 2 else
892  if (Flags and MB_DEFBUTTON3) = MB_DEFBUTTON3 then
893    DefButtonIndex := 3 else
894  if (Flags and MB_DEFBUTTON4) = MB_DEFBUTTON4 then
895    DefButtonIndex := 4 else
896    DefButtonIndex := 1;
897
898  DefButton := Low(TMsgDlgBtn);
899  for CurBtn := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
900  begin
901    DefButton := CurBtn;
902    if CurBtn in Buttons then
903      Dec(DefButtonIndex);
904    if DefButtonIndex = 0 then
905      break;
906  end;
907  Result := MessageDlg(Caption, Text, DlgType, Buttons, 0, DefButton);
908end;
909
910{** Return the localized or not title of dialog}
911function GetDialogCaption(idDiag: Integer): String;
912begin
913  case idDiag of
914    idDialogWarning : Result := rsMtWarning;
915    idDialogError   : Result := rsMtError;
916    idDialogInfo    : Result := rsMtInformation;
917    idDialogConfirm : Result := rsMtConfirmation;
918    idDialogShield  : Result := rsMtAuthentication;
919  else
920    Result := '?';
921  end;
922end;
923
924function GetDialogIcon(idDiag: Integer): TCustomBitmap;
925var
926  BitmapHandle, MaskHandle: HBitmap;
927begin
928  if ThemeServices.GetStockImage(idDiag, BitmapHandle, MaskHandle) then
929  begin
930    Result := TBitmap.Create;
931    Result.Handle := BitmapHandle;
932    if MaskHandle <> 0 then
933      Result.MaskHandle := MaskHandle;
934  end
935  else
936  if (idDiag < Low(DialogResName)) or (idDiag > High(DialogResName)) then
937    Result := nil
938  else
939  begin
940    Result := TPortableNetworkGraphic.Create;
941    Result.LoadFromResourceName(hInstance, DialogResName[idDiag]);
942  end;
943end;
944
945{$I lclcolordialog.inc}
946{$I commondialog.inc}
947{$I filedialog.inc}
948{$I finddialog.inc}
949{$I replacedialog.inc}
950{$I fontdialog.inc}
951{$I inputdialog.inc}
952{$I messagedialogs.inc}
953{$I promptdialog.inc}
954{$I colorbutton.inc}
955{$I taskdialog.inc}
956
957{ TCustomPrintDialog }
958
959constructor TCustomPrintDialog.Create(TheOwner: TComponent);
960begin
961  inherited Create(TheOwner);
962  FPrintRange:=prAllPages;
963  FCopies:=1;
964end;
965
966{ TCustomCopyToClipboardDialog }
967
968procedure TCustomCopyToClipboardDialog.DoCreate;
969begin
970  inherited DoCreate;
971
972  RegisterDialogForCopyToClipboard(Self);
973end;
974
975initialization
976  Forms.MessageBoxFunction := @DefaultMessageBox;
977  InterfaceBase.InputDialogFunction := @DefaultInputDialog;
978  InterfaceBase.PromptDialogFunction := @DefaultPromptDialog;
979  InterfaceBase.QuestionDialogFunction := @DefaultQuestionDialog;
980
981  RegisterPropertyToSkip(TCommonDialog, 'Width', 'Property streamed in older Lazarus revision','');
982  RegisterPropertyToSkip(TCommonDialog, 'Height', 'Property streamed in older Lazarus revision','');
983
984finalization
985  InterfaceBase.InputDialogFunction := nil;
986  InterfaceBase.QuestionDialogFunction := nil;
987
988end.
989