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