{ *********************************************************************** }
{                                                                         }
{ Delphi Visual Component Library                                         }
{                                                                         }
{ Copyright (c) 1995-2004 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit Borland.Vcl.Dialogs platform;

{$R-,T-,H+,X+}

interface

uses Windows, WinUtils, Messages, SysUtils, CommDlg, Printers,
  Classes, Graphics, Controls, Forms, StdCtrls,
  System.ComponentModel.Design.Serialization;

const

{ Maximum number of custom colors in color dialog }

  MaxCustomColors = 16;

type

{ TCommonDialog }

  [RootDesignerSerializerAttribute('', '', False)]
  TCommonDialog = class(TComponent)
  private
    FCtl3D: Boolean;
    FDefWndProc: IntPtr;
    FHelpContext: THelpContext;
    FHandle: HWnd;
    FRedirector: TWinControl;
    FObjectInstance: TFNWndProc;
    FTemplate: string;
    FTemplateModule: HINST;
    FOnClose: TNotifyEvent;
    FOnShow: TNotifyEvent;
    FDialogHookDelegate: TFNCommDlgHook;
    procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
    procedure WMInitDialog(var Message: TWMInitDialog); message WM_INITDIALOG;
    procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
    procedure MainWndProc(var Message: TMessage);
  strict private
    class var
      FHelpMsg: Cardinal;
  protected
    procedure DoClose; dynamic;
    procedure DoShow; dynamic;
    procedure WndProc(var Message: TMessage); virtual;
    function MessageHook(var Msg: TMessage): Boolean; virtual;
    function LaunchDialog(DialogData: IntPtr): Bool; virtual;
    function TaskModalDialog(DialogData: IntPtr): Bool; virtual;
    class property HelpMsg: Cardinal read FHelpMsg write FHelpMsg;
    property Template: string read FTemplate write FTemplate;
    property TemplateModule: HINST read FTemplateModule write FTemplateModule;
  public
    function DialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute: Boolean; overload; virtual;
    function Execute(ParentWnd: HWND): Boolean; overload; virtual; abstract;
    procedure DefaultHandler(var Message); virtual;
    property Handle: HWnd read FHandle;
  published
    property Ctl3D: Boolean read FCtl3D write FCtl3D default True;
    property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnShow: TNotifyEvent read FOnShow write FOnShow;
  end;

{ TOpenDialog }

  TOpenOption = (ofReadOnly, ofOverwritePrompt, ofHideReadOnly,
    ofNoChangeDir, ofShowHelp, ofNoValidate, ofAllowMultiSelect,
    ofExtensionDifferent, ofPathMustExist, ofFileMustExist, ofCreatePrompt,
    ofShareAware, ofNoReadOnlyReturn, ofNoTestFileCreate, ofNoNetworkButton,
    ofNoLongNames, ofOldStyleDialog, ofNoDereferenceLinks, ofEnableIncludeNotify,
    ofEnableSizing, ofDontAddToRecent, ofForceShowHidden);
  TOpenOptions = set of TOpenOption;

  TOpenOptionEx = (ofExNoPlacesBar);
  TOpenOptionsEx = set of TOpenOptionEx;

  TFileEditStyle = (fsEdit, fsComboBox);
  TOFNotifyEx = type CommDlg.TOFNotifyEx;
  {$NODEFINE TOFNotifyEx}
  TIncludeItemEvent = procedure (const OFN: TOFNotifyEx; var Include: Boolean) of object;

  TOpenDialog = class(TCommonDialog)
  private
    FHistoryList: TStrings;
    FOptions: TOpenOptions;
    FFilter: string;
    FFilterIndex: Integer;
    FCurrentFilterIndex: Integer;
    FInitialDir: string;
    FTitle: string;
    FDefaultExt: string;
    FFileName: TFileName;
    FFiles: TStrings;
    FFileEditStyle: TFileEditStyle;
    FOnSelectionChange: TNotifyEvent;
    FOnFolderChange: TNotifyEvent;
    FOnTypeChange: TNotifyEvent;
    FOnCanClose: TCloseQueryEvent;
    FOnIncludeItem: TIncludeItemEvent;
    FOptionsEx: TOpenOptionsEx;
    FExplorerHookDelegate: TFNCommDlgHook;
    function GetFileName: TFileName;
    function GetFilterIndex: Integer;
    procedure ReadFileEditStyle(Reader: TReader);
    procedure SetHistoryList(Value: TStrings);
    procedure SetInitialDir(const Value: string);
  protected
    function CanClose(var OpenFileName: TOpenFileName): Boolean;
    function DoCanClose: Boolean; dynamic;
    function LaunchDialog(DialogData: IntPtr): Bool; override;
    procedure DoSelectionChange; dynamic;
    procedure DoFolderChange; dynamic;
    procedure DoTypeChange; dynamic;
    procedure DoIncludeItem(const OFN: TOFNotifyEx; var Include: Boolean); dynamic;
    procedure DefineProperties(Filer: TFiler); override;
    procedure GetFileNames(var OpenFileName: TOpenFileName);
    function GetStaticRect: TRect; virtual;
    procedure WndProc(var Message: TMessage); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute(ParentWnd: HWND): Boolean; override;
    function ExplorerHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT;
    property FileEditStyle: TFileEditStyle read FFileEditStyle write FFileEditStyle;
    property Files: TStrings read FFiles;
    property HistoryList: TStrings read FHistoryList write SetHistoryList;
  published
    property DefaultExt: string read FDefaultExt write FDefaultExt;
    property FileName: TFileName read GetFileName write FFileName;
    property Filter: string read FFilter write FFilter;
    property FilterIndex: Integer read GetFilterIndex write FFilterIndex default 1;
    property InitialDir: string read FInitialDir write SetInitialDir;
    property Options: TOpenOptions read FOptions write FOptions default [ofHideReadOnly, ofEnableSizing];
    property OptionsEx: TOpenOptionsEx read FOptionsEx write FOptionsEx default [];
    property Title: string read FTitle write FTitle;
    property OnCanClose: TCloseQueryEvent read FOnCanClose write FOnCanClose;
    property OnFolderChange: TNotifyEvent read FOnFolderChange write FOnFolderChange;
    property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;
    property OnTypeChange: TNotifyEvent read FOnTypeChange write FOnTypeChange;
    property OnIncludeItem: TIncludeItemEvent read FOnIncludeItem write FOnIncludeItem;
  end;

{ TSaveDialog }

  TSaveDialog = class(TOpenDialog)
  protected
    function LaunchDialog(DialogData: IntPtr): Bool; override;
  end;

{ TColorDialog }

  TColorDialogOption = (cdFullOpen, cdPreventFullOpen, cdShowHelp,
    cdSolidColor, cdAnyColor);
  TColorDialogOptions = set of TColorDialogOption;

  TColorDialog = class(TCommonDialog)
  private
    FColor: TColor;
    FOptions: TColorDialogOptions;
    FCustomColors: TStrings;
    procedure SetCustomColors(Value: TStrings);
  protected
    function LaunchDialog(DialogData: IntPtr): Bool; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute(ParentWnd: HWND): Boolean; override;
  published
    property Color: TColor read FColor write FColor default clBlack;
    property Ctl3D default True;
    property CustomColors: TStrings read FCustomColors write SetCustomColors;
    property Options: TColorDialogOptions read FOptions write FOptions default [];
  end;

{ TFontDialog }

  TFontDialogOption = (fdAnsiOnly, fdTrueTypeOnly, fdEffects,
    fdFixedPitchOnly, fdForceFontExist, fdNoFaceSel, fdNoOEMFonts,
    fdNoSimulations, fdNoSizeSel, fdNoStyleSel,  fdNoVectorFonts,
    fdShowHelp, fdWysiwyg, fdLimitSize, fdScalableOnly, fdApplyButton);
  TFontDialogOptions = set of TFontDialogOption;

  TFontDialogDevice = (fdScreen, fdPrinter, fdBoth);

  TFDApplyEvent = procedure(Sender: TObject; Wnd: HWND) of object;

  TFontDialog = class(TCommonDialog)
  private
    FFont: TFont;
    FDevice: TFontDialogDevice;
    FOptions: TFontDialogOptions;
    FOnApply: TFDApplyEvent;
    FMinFontSize: Integer;
    FMaxFontSize: Integer;
    FFontCharsetModified: Boolean;
    FFontColorModified: Boolean;
    FFontHookDelegate: TFNCommDlgHook;
    procedure DoApply(Wnd: HWND);
    procedure SetFont(Value: TFont);
    procedure UpdateFromLogFont(const LogFont: TLogFont);
  protected
    function LaunchDialog(DialogData: IntPtr): Bool; override;
    procedure Apply(Wnd: HWND); dynamic;
    procedure WndProc(var Message: TMessage); override;
  public
    function FontDialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute(ParentWnd: HWND): Boolean; override;
  published
    property Font: TFont read FFont write SetFont;
    property Device: TFontDialogDevice read FDevice write FDevice default fdScreen;
    property MinFontSize: Integer read FMinFontSize write FMinFontSize default 0;
    property MaxFontSize: Integer read FMaxFontSize write FMaxFontSize default 0;
    property Options: TFontDialogOptions read FOptions write FOptions default [fdEffects];
    property OnApply: TFDApplyEvent read FOnApply write FOnApply;
  end;

{ TPrinterSetupDialog }

  TPrinterSetupDialog = class(TCommonDialog)
  protected
    function LaunchDialog(DialogData: IntPtr): Bool; override;
  public
    function Execute(ParentWnd: HWND): Boolean; override;
  end;

{ TPrintDialog }

  TPrintRange = (prAllPages, prSelection, prPageNums);
  TPrintDialogOption = (poPrintToFile, poPageNums, poSelection, poWarning,
    poHelp, poDisablePrintToFile);
  TPrintDialogOptions = set of TPrintDialogOption;

  TPrintDialog = class(TCommonDialog)
  private
    FFromPage: Integer;
    FToPage: Integer;
    FCollate: Boolean;
    FOptions: TPrintDialogOptions;
    FPrintToFile: Boolean;
    FPrintRange: TPrintRange;
    FMinPage: Integer;
    FMaxPage: Integer;
    FCopies: Integer;
    procedure SetNumCopies(Value: Integer);
  protected
    function LaunchDialog(DialogData: IntPtr): Bool; override;
  public
    function Execute(ParentWnd: HWND): Boolean; override;
  published
    property Collate: Boolean read FCollate write FCollate default False;
    property Copies: Integer read FCopies write SetNumCopies default 0;
    property FromPage: Integer read FFromPage write FFromPage default 0;
    property MinPage: Integer read FMinPage write FMinPage default 0;
    property MaxPage: Integer read FMaxPage write FMaxPage default 0;
    property Options: TPrintDialogOptions read FOptions write FOptions default [];
    property PrintToFile: Boolean read FPrintToFile write FPrintToFile default False;
    property PrintRange: TPrintRange read FPrintRange write FPrintRange default prAllPages;
    property ToPage: Integer read FToPage write FToPage default 0;
  end;

  TPrinterOrientation = Printers.TPrinterOrientation;  // required for Form Designer
  TPageSetupDialogOption = (psoDefaultMinMargins, psoDisableMargins,
    psoDisableOrientation, psoDisablePagePainting, psoDisablePaper, psoDisablePrinter,
    psoMargins, psoMinMargins, psoShowHelp, psoWarning, psoNoNetworkButton);
  TPageSetupDialogOptions = set of TPageSetupDialogOption;
  TPrinterKind = (pkDotMatrix, pkHPPCL);
  TPageType = (ptEnvelope, ptPaper);
  TPageSetupBeforePaintEvent = procedure (Sender: TObject; const PaperSize: SmallInt;
    const Orientation: TPrinterOrientation; const PageType: TPageType;
    var DoneDrawing: Boolean) of object;
  TPageMeasureUnits = (pmDefault, pmMillimeters, pmInches);
  TPaintPageEvent = procedure(Sender: TObject; Canvas: TCanvas; PageRect: TRect;
    var DoneDrawing: Boolean) of object;

  { TPageSetupDialog }

  TPageSetupDialog = class(TCommonDialog)
  private
    FOptions: TPageSetupDialogOptions;
    FMinMarginLeft: Integer;
    FMinMarginTop: Integer;
    FMinMarginRight: Integer;
    FMinMarginBottom: Integer;
    FMarginLeft: Integer;
    FMarginTop: Integer;
    FMarginRight: Integer;
    FMarginBottom: Integer;
    FPageWidth: Integer;
    FPageHeight: Integer;
    FPageSetupDlgRec: TPageSetupDlg;
    FBeforePaint: TPageSetupBeforePaintEvent;
    FUnits: TPageMeasureUnits;
    FOnDrawRetAddress: TPaintPageEvent;
    FOnDrawMinMargin: TPaintPageEvent;
    FOnDrawEnvStamp: TPaintPageEvent;
    FOnDrawFullPage: TPaintPageEvent;
    FOnDrawGreekText: TPaintPageEvent;
    FOnDrawMargin: TPaintPageEvent;
  protected
    function LaunchDialog(DialogData: IntPtr): Bool; override;
    function PagePaint(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT;
  public
    constructor Create(AOwner: TComponent); override;
    function Execute(ParentWnd: HWND): Boolean; override;
    function GetDefaults: Boolean;
    property PageSetupDlgRec: TPageSetupDlg read FPageSetupDlgRec;
  published
    property MinMarginLeft: Integer read FMinMarginLeft write FMinMarginLeft;
    property MinMarginTop: Integer read FMinMarginTop write FMinMarginTop;
    property MinMarginRight: Integer read FMinMarginRight write FMinMarginRight;
    property MinMarginBottom: Integer read FMinMarginBottom write FMinMarginBottom;
    property MarginLeft: Integer read FMarginLeft write FMarginLeft;
    property MarginTop: Integer read FMarginTop write FMarginTop;
    property MarginRight: Integer read FMarginRight write FMarginRight;
    property MarginBottom: Integer read FMarginBottom write FMarginBottom;
    property Options: TPageSetupDialogOptions read FOptions write FOptions
      default [psoDefaultMinMargins];
    property PageWidth: Integer read FPageWidth write FPageWidth;
    property PageHeight: Integer read FPageHeight write FPageHeight;
    property Units: TPageMeasureUnits read FUnits write FUnits default pmDefault;
    property BeforePaint: TPageSetupBeforePaintEvent read FBeforePaint
      write FBeforePaint;
    property OnDrawFullPage: TPaintPageEvent read FOnDrawFullPage write FOnDrawFullPage;
    property OnDrawMinMargin: TPaintPageEvent read FOnDrawMinMargin write FOnDrawMinMargin;
    property OnDrawMargin: TPaintPageEvent read FOnDrawMargin write FOnDrawMargin;
    property OnDrawGreekText: TPaintPageEvent read FOnDrawGreekText write FOnDrawGreekText;
    property OnDrawEnvStamp: TPaintPageEvent read FOnDrawEnvStamp write FOnDrawEnvStamp;
    property OnDrawRetAddress: TPaintPageEvent read FOnDrawRetAddress write FOnDrawRetAddress;
  end;

{ TFindDialog }

  TFindOption = (frDown, frFindNext, frHideMatchCase, frHideWholeWord,
    frHideUpDown, frMatchCase, frDisableMatchCase, frDisableUpDown,
    frDisableWholeWord, frReplace, frReplaceAll, frWholeWord, frShowHelp);
  TFindOptions = set of TFindOption;

  TFindReplaceFunc = function(var FindReplace: TFindReplace): HWnd;

  TFindDlgResources = class
  private
    FFindHandle: HWnd;
    FFindReplacePtr: IntPtr;
    FObjectInstance: TFNWndProc;
  strict protected
    procedure Finalize; override;
  end;

  TFindDialog = class(TCommonDialog)
  private
    FOptions: TFindOptions;
    FPosition: TPoint;
    FOnFind: TNotifyEvent;
    FOnReplace: TNotifyEvent;
    FResources: TFindDlgResources;
    FOldWindowLong: IntPtr;
    FFindText: string;
    FReplaceText: string;
    FFRDH: TFNCommDlgHook;
    FFRWP: TFNWndProc;
    function GetFindText: string;
    function GetLeft: Integer;
    function GetPosition: TPoint;
    function GetReplaceText: string;
    function GetTop: Integer;
    procedure SetFindText(const Value: string);
    procedure SetLeft(Value: Integer);
    procedure SetPosition(const Value: TPoint);
    procedure SetReplaceText(const Value: string);
    procedure SetTop(Value: Integer);
    property ReplaceText: string read GetReplaceText write SetReplaceText;
    property OnReplace: TNotifyEvent read FOnReplace write FOnReplace;
  protected
    function LaunchDialog(DialogData: IntPtr): Bool; override;
    function MessageHook(var Msg: TMessage): Boolean; override;
    procedure Find; dynamic;
    procedure Replace; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function FindReplaceDialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT;
    function FindReplaceWndProc(Wnd: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT;
    procedure CloseDialog;
    function Execute(ParentWnd: HWND): Boolean; override;
    property Left: Integer read GetLeft write SetLeft;
    property Position: TPoint read GetPosition write SetPosition;
    property Top: Integer read GetTop write SetTop;
  published
    property FindText: string read GetFindText write SetFindText;
    property Options: TFindOptions read FOptions write FOptions default [frDown];
    property OnFind: TNotifyEvent read FOnFind write FOnFind;
  end;

{ TReplaceDialog }

  TReplaceDialog = class(TFindDialog)
  protected
    function LaunchDialog(DialogData: IntPtr): Bool; override;
  published
    property ReplaceText;
    property OnReplace;
  end;

{ Message dialog }

type
  TMsgDlgType = (mtWarning, mtError, mtInformation, mtConfirmation, mtCustom);
  TMsgDlgBtn = (mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, mbIgnore,
    mbAll, mbNoToAll, mbYesToAll, mbHelp);
  TMsgDlgButtons = set of TMsgDlgBtn;

const
  mbYesNo = [mbYes, mbNo];
  mbYesNoCancel = [mbYes, mbNo, mbCancel];
  mbYesAllNoAllCancel = [mbYes, mbYesToAll, mbNo, mbNoToAll, mbCancel];
  mbOKCancel = [mbOK, mbCancel];
  mbAbortRetryIgnore = [mbAbort, mbRetry, mbIgnore];
  mbAbortIgnore = [mbAbort, mbIgnore];

function CreateMessageDialog(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons): TForm;

function MessageDlg(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
function MessageDlgPos(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer;
function MessageDlgPosHelp(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
  const HelpFileName: string): Integer;

procedure ShowMessage(const Msg: string);
procedure ShowMessageFmt(const Msg: string; Params: array of const);
procedure ShowMessagePos(const Msg: string; X, Y: Integer);

{ Input dialog }

function InputBox(const ACaption, APrompt, ADefault: string): string;
function InputQuery(const ACaption, APrompt: string;
  var Value: string): Boolean;

function PromptForFileName(var AFileName: string; const AFilter: string = '';
  const ADefaultExt: string = ''; const ATitle: string = '';
  const AInitialDir: string = ''; SaveDialog: Boolean = False): Boolean;

{ Win98 and Win2k will default to the "My Documents" folder if the InitialDir
  property is empty and no files of the filtered type are contained in the
  current directory. Set this flag to True to force TOpenDialog and descendents
  to always open in the current directory when InitialDir is empty. (Same
  behavior as setting InitialDir to '.') }
var
  ForceCurrentDirectory: Boolean = False;

implementation

uses
  Dlgs, Math, Types, ExtCtrls, StrUtils, Consts,
  System.Runtime.InteropServices, System.Collections, System.Threading;

{ Private globals }

var
  FindMsg: Cardinal;

{ Center the given window on the screen }

procedure CenterWindow(Wnd: HWnd);
var
  Rect: TRect;
  Monitor: TMonitor;
begin
  GetWindowRect(Wnd, Rect);
  if Application.MainForm <> nil then
  begin
    if Assigned(Screen.ActiveForm) then
      Monitor := Screen.ActiveForm.Monitor
    else
      Monitor := Application.MainForm.Monitor;
  end
  else
    Monitor := Screen.Monitors[0];
  SetWindowPos(Wnd, 0,
    Monitor.Left + ((Monitor.Width - Rect.Right + Rect.Left) div 2),
    Monitor.Top + ((Monitor.Height - Rect.Bottom + Rect.Top) div 3),
    0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;

{ Generic dialog hook. Centers the dialog on the screen in response to
  the WM_INITDIALOG message }

function TCommonDialog.DialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT;
begin
  Result := 0;
  if Msg = WM_INITDIALOG then
  begin
    CenterWindow(Wnd);
    FHandle := Wnd;
    FDefWndProc := SetWindowLong(Wnd, GWL_WNDPROC, FObjectInstance);
    CallWindowProc(FObjectInstance, Wnd, Msg, WParam, LParam);
  end;
end;

{ TRedirectorWindow }
{ A redirector window is used to put the find/replace dialog into the
  ownership chain of a form, but intercept messages that CommDlg.dll sends
  exclusively to the find/replace dialog's owner.  TRedirectorWindow
  creates its hidden window handle as owned by the target form, and the
  find/replace dialog handle is created as owned by the redirector.  The
  redirector wndproc forwards all messages to the find/replace component.
}

type
  TRedirectorWindow = class(TWinControl)
  private
    FCommonDialog: TCommonDialog;
    FFormHandle: THandle;
    procedure CMRelease(var Message); message CM_Release;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WndProc(var Message: TMessage); override;
  end;

procedure TRedirectorWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := WS_VISIBLE or WS_POPUP;
    WndParent := FFormHandle;
  end;
end;

procedure TRedirectorWindow.WndProc(var Message: TMessage);
begin
  inherited WndProc(Message);
  if (Message.Result = 0) and (Message.Msg <> CM_RELEASE) and
    Assigned(FCommonDialog) then
    Message.Result := Integer(FCommonDialog.MessageHook(Message));
end;

procedure TRedirectorWindow.CMRelease(var Message);
begin
  Free;
end;

{ TCommonDialog }

constructor TCommonDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDialogHookDelegate := @DialogHook;
  FCtl3D := True;
end;

destructor TCommonDialog.Destroy;
begin
  if Assigned(FRedirector) then
  begin
    TRedirectorWindow(FRedirector).FCommonDialog := nil;
    FreeAndNil(FRedirector);
  end;
  inherited Destroy;
end;

function TCommonDialog.Execute: Boolean;
var
  ParentWnd: HWND;
begin
  ParentWnd := Application.ActiveFormHandle;
  if ParentWnd = 0 then
    ParentWnd := Application.Handle;
  Result := Execute(ParentWnd);
end;

function TCommonDialog.MessageHook(var Msg: TMessage): Boolean;
begin
  Result := False;
  if (Msg.Msg = Integer(HelpMsg)) and (FHelpContext <> 0) then
  begin
    Application.HelpContext(FHelpContext);
    Result := True;
  end;
end;

procedure TCommonDialog.DefaultHandler(var Message);
begin
  if FHandle <> 0 then
    with UnwrapMessage(TObject(Message)) do
      Result := CallWindowProc(FDefWndProc, FHandle, Msg, WParam, LParam);
end;

procedure TCommonDialog.MainWndProc(var Message: TMessage);
begin
  try
    WndProc(Message);
  except
    Application.HandleException(Self);
  end;
end;

procedure TCommonDialog.WndProc(var Message: TMessage);
begin
  Dispatch(Message);
end;

procedure TCommonDialog.WMDestroy(var Message: TWMDestroy);
begin
  inherited;
  DoClose;
end;

procedure TCommonDialog.WMInitDialog(var Message: TWMInitDialog);
begin
  { Called only by non-explorer style dialogs }
  DoShow;
  { Prevent any further processing }
  Message.Result := 0;
end;

procedure TCommonDialog.WMNCDestroy(var Message: TWMNCDestroy);
begin
  inherited;
  FHandle := 0;
end;

function TCommonDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  Result := False;
end;

function TCommonDialog.TaskModalDialog(DialogData: IntPtr): Bool;
var
  ActiveWindow: HWnd;
  WindowList: TObject;
  FocusState: TFocusState;
begin
  ActiveWindow := Application.ActiveFormHandle;
  WindowList := DisableTaskWindows(0);
  FocusState := SaveFocusState;
  try
    FObjectInstance := WinUtils.MakeObjectInstance(MainWndProc);
    try
      try
        Result := LaunchDialog(DialogData);
      finally
        FHandle := 0;
      end;
    finally
      WinUtils.FreeObjectInstance(FObjectInstance);
      FObjectInstance := nil;
    end;
  finally
    EnableTaskWindows(WindowList);
    SetActiveWindow(ActiveWindow);
    RestoreFocusState(FocusState);
    FreeAndNil(FRedirector);
  end;
end;

procedure TCommonDialog.DoClose;
begin
  if Assigned(FOnClose) then FOnClose(Self);
end;

procedure TCommonDialog.DoShow;
begin
  if Assigned(FOnShow) then FOnShow(Self);
end;

{ Open and Save dialog routines }

function TOpenDialog.ExplorerHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT;
var
  Hdr: TNMHdr;
begin
  Result := 0;
  if Msg = WM_INITDIALOG then
  begin
    FHandle := Wnd;
    FDefWndProc := SetWindowLong(Wnd, GWL_WNDPROC, FObjectInstance);
    CallWindowProc(FObjectInstance, Wnd, Msg, WParam, LParam);
  end
  else if (Msg = WM_NOTIFY) then
  begin
    Hdr := TNMHdr(Marshal.PtrToStructure(IntPtr(LParam), TypeOf(TNMHdr)));
    if Hdr.code = CDN_INITDONE then
      CenterWindow(GetWindowLong(Wnd, GWL_HWNDPARENT));
  end;
end;

{ TOpenDialog }

constructor TOpenDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHistoryList := TStringList.Create;
  FOptions := [ofHideReadOnly, ofEnableSizing];
  FOptionsEx := [];
  FFiles := TStringList.Create;
  FFilterIndex := 1;
  FFileEditStyle := fsEdit;
  FExplorerHookDelegate := @ExplorerHook;
end;

destructor TOpenDialog.Destroy;
begin
  FFiles.Free;
  FHistoryList.Free;
  inherited Destroy;
end;

function TOpenDialog.CanClose(var OpenFileName: TOpenFileName): Boolean;
begin
  GetFileNames(OpenFileName);
  Result := DoCanClose;
  FFiles.Clear;
end;

procedure TOpenDialog.WndProc(var Message: TMessage);
var
  Index: Integer;
  Include: Boolean;
  OFN: TOFNotify;
  OFNX: TOFNotifyEx;
  OFileName: TOpenFileName;
begin
  Message.Result := 0;
  { If not ofOldStyleDialog then DoShow on CDN_INITDONE, not WM_INITDIALOG }
  if (Message.Msg = WM_INITDIALOG) and not (ofOldStyleDialog in Options) then Exit
  else if (Message.Msg = WM_NOTIFY) then
  begin
    OFN := TOFNotify(Marshal.PtrToStructure(IntPtr(Message.lParam), TypeOf(TOFNotify)));
    case (OFN.hdr.code) of
      CDN_FILEOK:
        begin
          OFileName := TOpenFileName(Marshal.PtrToStructure(IntPtr(OFN.lpOFN),
            TypeOf(TOpenFileName)));
          if not CanClose(OFileName) then
          begin
            Message.Result := 1;
            SetWindowLong(Handle, DWL_MSGRESULT, Message.Result);
            Exit;
          end;
        end;
      CDN_INITDONE: DoShow;
      CDN_SELCHANGE: DoSelectionChange;
      CDN_FOLDERCHANGE: DoFolderChange;
      CDN_TYPECHANGE:
        begin
          OFileName := TOpenFileName(Marshal.PtrToStructure(IntPtr(OFN.lpOFN),
            TypeOf(TOpenFileName)));
          Index := OFileName.nFilterIndex;
          if Index <> FCurrentFilterIndex then
          begin
            FCurrentFilterIndex := Index;
            DoTypeChange;
          end;
        end;
      CDN_INCLUDEITEM:
        if Message.LParam <> 0 then
        begin
          OFNX := TOFNotifyEx(Marshal.PtrToStructure(IntPtr(Message.LParam),
            TypeOf(TOFNotifyEx)));
          Include := True;
          DoIncludeItem(OFNX, Include);
          Message.Result := Byte(Include);
        end;
    end;
  end;
  inherited WndProc(Message);
end;

function TOpenDialog.DoCanClose: Boolean;
begin
  Result := True;
  if Assigned(FOnCanClose) then FOnCanClose(Self, Result);
end;

procedure TOpenDialog.DoSelectionChange;
begin
  if Assigned(FOnSelectionChange) then FOnSelectionChange(Self);
end;

procedure TOpenDialog.DoFolderChange;
begin
  if Assigned(FOnFolderChange) then FOnFolderChange(Self);
end;

procedure TOpenDialog.DoTypeChange;
begin
  if Assigned(FOnTypeChange) then FOnTypeChange(Self);
end;

procedure TOpenDialog.ReadFileEditStyle(Reader: TReader);
begin
  { Ignore FileEditStyle }
  Reader.ReadIdent;
end;

procedure TOpenDialog.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('FileEditStyle', ReadFileEditStyle, nil, False);
end;

function TOpenDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  Result := GetOpenFileName(DialogData);
end;

procedure TOpenDialog.GetFileNames(var OpenFileName: TOpenFileName);
var
  Separator: Char;

  function ExtractFileName(Str: IntPtr; Idx, MaxPos: Integer; var Name: TFileName): Integer;
  var
    C: Char;
  begin
    Name := '';
    Result := Idx;
    while Result < MaxPos do
    begin
      if Marshal.SystemDefaultCharSize = 1 then
        C := Char(Marshal.ReadByte(Str, Result))
      else
        C := Char(Marshal.ReadInt16(Str, Result));
      if (C = Separator) or (C = #0) then // the end of this string
      begin
        if Result = Idx then
          Result := MaxPos
        else
          Inc(Result, Marshal.SystemDefaultCharSize);
        Exit;
      end;
      Name := Name + C;
      Inc(Result, Marshal.SystemDefaultCharSize);
    end;
  end;

  procedure ExtractFileNames(buffer: IntPtr; maxLen: Integer);
  var
    DirName, FileName: TFileName;
    Pos: Integer;
  begin
    Pos := 0;
    Pos := ExtractFileName(buffer, Pos, maxLen, DirName);
    Pos := ExtractFileName(buffer, Pos, maxLen, FileName);
    if FileName = '' then
      FFiles.Add(DirName)
    else
    begin
      if DirName[Length(DirName)] <> '\' then
        DirName := DirName + '\';
      repeat
        if (FileName[1] <> '\') and ((Length(FileName) <= 3) or
          (FileName[2] <> ':') or (FileName[3] <> '\')) then
          FileName := DirName + FileName;
        FFiles.Add(FileName);
        Pos := ExtractFileName(buffer, Pos, maxLen, FileName);
      until FileName = '';
    end;
  end;

begin
  Separator := #0;
  if (ofAllowMultiSelect in FOptions) and
    ((ofOldStyleDialog in FOptions) or not NewStyleControls) then
    Separator := ' ';
  with OpenFileName do
  begin
    if ofAllowMultiSelect in FOptions then
    begin
      ExtractFileNames(lpstrFile, nMaxFile);
      FFileName := FFiles[0];
    end else
    begin
      FFileName := Marshal.PtrToStringAuto(lpstrFile);
      FFiles.Add(FFileName);
    end;
  end;
end;

function TOpenDialog.GetStaticRect: TRect;
begin
  if FHandle <> 0 then
  begin
    if not (ofOldStyleDialog in Options) then
    begin
      GetWindowRect(GetDlgItem(FHandle, stc32), Result);
      MapWindowPoints(0, FHandle, Result, 2);
    end
    else GetClientRect(FHandle, Result)
  end
  else Result := EmptyRect;
end;

function TOpenDialog.GetFileName: TFileName;
var
  S: String;
  P: Integer;
begin
  if NewStyleControls and (FHandle <> 0) then
  begin
    SendGetTextMessage(GetParent(FHandle), CDM_GETFILEPATH, MAX_PATH, S, MAX_PATH, False);
    P := Pos(#0, S);
    if P > 0 then
      Result := Copy(S, 1, P - 1)
    else
      Result := S;
  end
  else
    Result := FFileName;
end;

function TOpenDialog.GetFilterIndex: Integer;
begin
  if FHandle <> 0 then
    Result := FCurrentFilterIndex
  else
    Result := FFilterIndex;
end;

procedure TOpenDialog.SetHistoryList(Value: TStrings);
begin
  FHistoryList.Assign(Value);
end;

procedure TOpenDialog.SetInitialDir(const Value: string);
var
  L: Integer;
begin
  L := Length(Value);
  if (L > 1) and IsPathDelimiter(Value, L)
    and not IsDelimiter(':', Value, L - 1) then Dec(L);
  FInitialDir := Copy(Value, 1, L);
end;

const
  MultiSelectBufferSize = High(Word) - 16;
  OpenOptions: array [TOpenOption] of DWORD = (
    OFN_READONLY, OFN_OVERWRITEPROMPT, OFN_HIDEREADONLY,
    OFN_NOCHANGEDIR, OFN_SHOWHELP, OFN_NOVALIDATE, OFN_ALLOWMULTISELECT,
    OFN_EXTENSIONDIFFERENT, OFN_PATHMUSTEXIST, OFN_FILEMUSTEXIST,
    OFN_CREATEPROMPT, OFN_SHAREAWARE, OFN_NOREADONLYRETURN,
    OFN_NOTESTFILECREATE, OFN_NONETWORKBUTTON, OFN_NOLONGNAMES,
    OFN_EXPLORER, OFN_NODEREFERENCELINKS, OFN_ENABLEINCLUDENOTIFY,
    OFN_ENABLESIZING, OFN_DONTADDTORECENT, OFN_FORCESHOWHIDDEN);

  OpenOptionsEx: array [TOpenOptionEx] of DWORD = (OFN_EX_NOPLACESBAR);

function TOpenDialog.Execute(ParentWnd: HWND): Boolean;
var
  Option: TOpenOption;
  OptionEx: TOpenOptionEx;
  OpenFilename: TOpenFilename;

  function AllocFilterStr(const S: string): string;
  var
    SepPos: Integer;
  begin
    Result := '';
    if S <> '' then
    begin
      Result := S + #0;  // double null terminators
      SepPos := Pos('|', Result) - 1;
      while SepPos >= 0 do
      begin
        Result[SepPos + 1] := #0; // adjust because OP strings are 1-offset
        Inc(SepPos);
        SepPos := PosEx('|', Result, SepPos + 1) - 1;
      end;
    end;
    Result := Result + #0; // add final null terminator
  end;

var
  TempFilter, TempExt: string;
  TempFilename: TBytes;
  Mem: IntPtr;
  I: Integer;
begin
  CheckThreadingModel(System.Threading.ApartmentState.STA);
  FFiles.Clear;
  with OpenFilename do
  begin
    if (Win32MajorVersion >= 5) and (Win32Platform = VER_PLATFORM_WIN32_NT) or { Win2k }
    ((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and (Win32MajorVersion >= 4) and (Win32MinorVersion >= 90)) then { WinME }
    begin
      lStructSize := Marshal.SizeOf(TypeOf(TOpenFilename));
      pvReserved := nil;
      dwReserved := 0;
    end
    else
      lStructSize := Marshal.SizeOf(TypeOf(TOpenFilename)) -
        (SizeOf(DWORD) shl 1) - SizeOf(IntPtr); { subtract size of added fields }
    hInstance := WinUtils.HInstance;
    TempFilter := AllocFilterStr(FFilter);
    lpstrFilter := TempFilter;
    lpstrCustomFilter := nil;
    nFilterIndex := FFilterIndex;
    FCurrentFilterIndex := FFilterIndex;
    lpstrFileTitle := nil;
    nMaxFileTitle := 0;
    if (FInitialDir = '') and ForceCurrentDirectory then
      lpstrInitialDir := '.'
    else
      lpstrInitialDir := FInitialDir;
    lpstrTitle := FTitle;
    Flags := OFN_ENABLEHOOK;
    FlagsEx := 0;

    for Option := Low(Option) to High(Option) do
      if Option in FOptions then
        Flags := Flags or OpenOptions[Option];
    if NewStyleControls then
    begin
      Flags := Flags xor OFN_EXPLORER;
      if (Win32MajorVersion >= 5) and (Win32Platform = VER_PLATFORM_WIN32_NT) or { Win2k }
      ((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and (Win32MajorVersion >= 4) and (Win32MinorVersion >= 90)) then { WinME }
        for OptionEx := Low(OptionEx) to High(OptionEx) do
          if OptionEx in FOptionsEx then
            FlagsEx := FlagsEx or OpenOptionsEx[OptionEx];
    end
    else
      Flags := Flags and not OFN_EXPLORER;
    nFileOffset := 0;
    nFileExtension := 0;
    lCustData := 0;
    TempExt := FDefaultExt;
    if (TempExt = '') and (Flags and OFN_EXPLORER = 0) then
    begin
      TempExt := ExtractFileExt(FFilename);
      Delete(TempExt, 1, 1);
    end;
    if TempExt <> '' then
      lpstrDefExt := TempExt
    else
      lpstrDefExt := '';
    if (ofOldStyleDialog in Options) or not NewStyleControls then
      lpfnHook := FDialogHookDelegate
    else
      lpfnHook := FExplorerHookDelegate;
    if Length(Template) > 0 then
    begin
      Flags := Flags or OFN_ENABLETEMPLATE;
      lpTemplateName := Template;
      if FTemplateModule <> 0 then
        hInstance := FTemplateModule;
    end;
    FRedirector := TRedirectorWindow.Create(nil);
    with TRedirectorWindow(FRedirector) do
    begin
      FCommonDialog := Self;
      FFormHandle := ParentWnd;
    end;
    hWndOwner := FRedirector.Handle;
    if ofAllowMultiSelect in FOptions then
      nMaxFile := MultiSelectBufferSize else
      nMaxFile := MAX_PATH;
    TempFileName := PlatformBytesOf(FFileName);
  end;
  Mem := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TOpenFilename)));
  try
    OpenFileName.lpstrFile := Marshal.AllocHGlobal((OpenFileName.nMaxFile + 1) * Marshal.SystemDefaultCharSize);
    try
      Marshal.Copy(TempFileName, 0, OpenFileName.lpstrFile, Length(TempFileName));
      for I := Length(TempFileName) to OpenFileName.nMaxFile * Marshal.SystemDefaultCharSize do
        Marshal.WriteByte(OpenFileName.lpstrFile, I, 0);
      Marshal.StructureToPtr(TObject(OpenFileName), Mem, False);
      Result := TaskModalDialog(Mem);
      if Result then
      begin
        OpenFileName := TOpenFilename(Marshal.PtrToStructure(Mem,
          TypeOf(TOpenFilename)));
        GetFileNames(OpenFilename);
        if (OpenFileName.Flags and OFN_EXTENSIONDIFFERENT) <> 0 then
          Include(FOptions, ofExtensionDifferent) else
          Exclude(FOptions, ofExtensionDifferent);
        if (OpenFileName.Flags and OFN_READONLY) <> 0 then
          Include(FOptions, ofReadOnly) else
          Exclude(FOptions, ofReadOnly);
        FFilterIndex := OpenFileName.nFilterIndex;
      end;
    finally
      Marshal.FreeHGlobal(OpenFileName.lpstrFile);
    end;
  finally
    // just in case....
    Marshal.WriteInt32(Mem,
      Integer(Marshal.OffsetOf(TypeOf(TOpenFilename), 'lpstrFile')), 0);
    Marshal.DestroyStructure(Mem, TypeOf(TOpenFilename));
  end;
end;

procedure TOpenDialog.DoIncludeItem(const OFN: TOFNotifyEx; var Include: Boolean);
begin
  if Assigned(FOnIncludeItem) then FOnIncludeItem(OFN, Include);
end;

{ TSaveDialog }

function TSaveDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  Result := GetSaveFileName(DialogData);
end;

{ TColorDialog }

constructor TColorDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCustomColors := TStringList.Create;
end;

destructor TColorDialog.Destroy;
begin
  FCustomColors.Free;
  inherited Destroy;
end;

function TColorDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  Result := ChooseColor(DialogData);
end;

const
  DialogOptions: array[TColorDialogOption] of DWORD = (
    CC_FULLOPEN, CC_PREVENTFULLOPEN, CC_SHOWHELP, CC_SOLIDCOLOR,
    CC_ANYCOLOR);
  ColorPrefix = 'Color';

function TColorDialog.Execute(ParentWnd: HWND): Boolean;
var
  ChooseColorRec: TChooseColor;
  Option: TColorDialogOption;
  CustomColorsArray, DialogData: IntPtr;

  procedure GetCustomColorsArray;
  var
    I, Val: Integer;
  begin
    for I := 0 to MaxCustomColors - 1 do
    begin
      Val := Marshal.ReadInt32(CustomColorsArray,
        I * sizeof(Longint));
      FCustomColors.Values[ColorPrefix + Char(Ord('A') + I)] :=
        Format('%.6x', [Val]);
    end;
  end;

  procedure SetCustomColorsArray;
  var
    Value: string;
    I: Integer;
  begin
    CustomColorsArray := Marshal.AllocHGlobal(MaxCustomColors * sizeof(Longint));
    for I := 0 to MaxCustomColors - 1 do
    begin
      Value := FCustomColors.Values[ColorPrefix + Char(Ord('A') + I)];
      if Value <> '' then
        Marshal.WriteInt32(CustomColorsArray, I * sizeof(Longint),
          StrToInt('$' + Value))
      else
        Marshal.WriteInt32(CustomColorsArray, I * sizeof(Longint), -1);
    end;
  end;

  procedure FreeCustomColorsArray;
  begin
    Marshal.FreeHGlobal(CustomColorsArray);
  end;

begin
  with ChooseColorRec do
  begin
    SetCustomColorsArray;
    try
      lStructSize := Marshal.SizeOf(TypeOf(ChooseColorRec));
      hInstance := WinUtils.HInstance;
      rgbResult := ColorToRGB(FColor);
      lpCustColors := CustomColorsArray;
      LCustData := 0;
      Flags := CC_RGBINIT or CC_ENABLEHOOK;
      for Option := Low(Option) to High(Option) do
        if Option in FOptions then
          Flags := Flags or DialogOptions[Option];
      lpTemplateName := Template;
      if Length(Template) > 0 then
      begin
        Flags := Flags or CC_ENABLETEMPLATE;
        if FTemplateModule <> 0 then
          hInstance := FTemplateModule;
      end;
      lpfnHook := FDialogHookDelegate;
      FRedirector := TRedirectorWindow.Create(nil);
      with TRedirectorWindow(FRedirector) do
      begin
        FCommonDialog := Self;
        FFormHandle := ParentWnd;
      end;
      hWndOwner := FRedirector.Handle;
      DialogData := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TChooseColor)));
      try
        Marshal.StructureToPtr(TObject(ChooseColorRec), DialogData, False);
        Result := TaskModalDialog(DialogData);
        if Result then
        begin
          ChooseColorRec := TChooseColor(Marshal.PtrToStructure(DialogData,
            TypeOf(TChooseColor)));
          FColor := ChooseColorRec.rgbResult;
          GetCustomColorsArray;
        end;
      finally
        Marshal.DestroyStructure(DialogData, TypeOf(TChooseColor));
      end;
    finally
      FreeCustomColorsArray;
    end;
  end;
end;

procedure TColorDialog.SetCustomColors(Value: TStrings);
begin
  FCustomColors.Assign(Value);
end;

{ TFontDialog }

const
  IDAPPLYBTN = $402;

function TFontDialog.FontDialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT;
begin
  if (Msg = WM_COMMAND) and ((WParam and $FFFF) = IDAPPLYBTN) and
    (((WParam shr 16) and $FFFF) = BN_CLICKED) then
  begin
    DoApply(Wnd);
    Result := 1;
  end else
    Result := DialogHook(Wnd, Msg, wParam, lParam);
end;

constructor TFontDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFont := TFont.Create;
  FOptions := [fdEffects];
  FFontHookDelegate := @FontDialogHook;
end;

destructor TFontDialog.Destroy;
begin
  FFont.Free;
  inherited Destroy;
end;

procedure TFontDialog.WndProc(var Message: TMessage);
begin
  { Make sure we only take values from the color combobox and script combobox
    if they have been changed. }
  if (Message.Msg = WM_COMMAND) and (Message.WParamHi = CBN_SELENDOK) then
    if (Message.WParamLo = cmb4) then FFontColorModified := True
    else if (Message.WParamLo = cmb5) then FFontCharsetModified := True;
  inherited WndProc(Message);
end;

procedure TFontDialog.Apply(Wnd: HWND);
begin
  if Assigned(FOnApply) then FOnApply(Self, Wnd);
end;

const
  IDCOLORCMB = $473;

procedure TFontDialog.DoApply(Wnd: HWND);
var
  I: Integer;
  LogFont: TLogFont;
  Mem: IntPtr;
begin
  Mem := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TLogFont)));
  try
    SendMessage(Wnd, WM_CHOOSEFONT_GETLOGFONT, 0, LongInt(Mem));
    LogFont := TLogFont(Marshal.PtrToStructure(Mem, TypeOf(TLogFont)));
  finally
    Marshal.DestroyStructure(Mem, TypeOf(TLogFont));
  end;
  UpdateFromLogFont(LogFont);
  I := SendDlgItemMessage(Wnd, IDCOLORCMB, CB_GETCURSEL, 0, 0);
  if I <> CB_ERR then
    Font.Color := SendDlgItemMessage(Wnd, IDCOLORCMB, CB_GETITEMDATA, I, 0);
  try
    Apply(Wnd);
  except
    Application.HandleException(Self);
  end;
end;

function TFontDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  Result := ChooseFont(DialogData);
end;

const
  FontOptions: array[TFontDialogOption] of DWORD = (
    CF_ANSIONLY, CF_TTONLY, CF_EFFECTS, CF_FIXEDPITCHONLY, CF_FORCEFONTEXIST,
    CF_NOFACESEL, CF_NOOEMFONTS, CF_NOSIMULATIONS, CF_NOSIZESEL,
    CF_NOSTYLESEL, CF_NOVECTORFONTS, CF_SHOWHELP,
    CF_WYSIWYG or CF_BOTH or CF_SCALABLEONLY, CF_LIMITSIZE,
    CF_SCALABLEONLY, CF_APPLY);
  Devices: array[TFontDialogDevice] of DWORD = (
    CF_SCREENFONTS, CF_PRINTERFONTS, CF_BOTH);

function TFontDialog.Execute(ParentWnd: HWND): Boolean;
var
  ChooseFontRec: TChooseFont;
  LogFont: TLogFont;
  Option: TFontDialogOption;
  OriginalFaceName: string;
  Mem, DialogData: IntPtr;
begin
  with ChooseFontRec do
  begin
    lStructSize := Marshal.SizeOf(TypeOf(ChooseFontRec));
    hDC := 0;
    if FDevice <> fdScreen then hDC := Printer.Handle;
    Flags := Devices[FDevice] or (CF_INITTOLOGFONTSTRUCT or CF_ENABLEHOOK);
    for Option := Low(Option) to High(Option) do
      if Option in FOptions then
        Flags := Flags or FontOptions[Option];
    if Assigned(FOnApply) then Flags := Flags or CF_APPLY;
    lpTemplateName := Template;
    if Length(Template) > 0 then
    begin
      Flags := Flags or CF_ENABLETEMPLATE;
      if FTemplateModule <> 0 then
        hInstance := FTemplateModule;
    end;
    rgbColors := Font.Color;
    lCustData := 0;
    lpfnHook := FFontHookDelegate;
    nSizeMin := FMinFontSize;
    nSizeMax := FMaxFontSize;
    if nSizeMin > nSizeMax then Flags := Flags and (not CF_LIMITSIZE);
    FRedirector := TRedirectorWindow.Create(nil);
    with TRedirectorWindow(FRedirector) do
    begin
      FCommonDialog := Self;
      FFormHandle := ParentWnd;
    end;
    hWndOwner := FRedirector.Handle;
    FFontColorModified := False;
    FFontCharsetModified := False;
    Mem := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TLogFont)));
    try
      GetObject(Font.Handle, Marshal.SizeOf(TypeOf(TLogFont)), LogFont);
      Marshal.StructureToPtr(TObject(LogFont), Mem, False);
      lpLogFont := Mem;
      OriginalFaceName := LogFont.lfFaceName;
      DialogData := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TChooseFont)));
      try
        Marshal.StructureToPtr(TObject(ChooseFontRec), DialogData, False);
        Result := TaskModalDialog(DialogData);
        if Result then
        begin
          ChooseFontRec := TChooseFont(Marshal.PtrToStructure(DialogData,
            TypeOf(TChooseFont)));
          LogFont := TLogFont(Marshal.PtrToStructure(Mem, TypeOf(TLogFont)));
          if CompareText(OriginalFaceName, LogFont.lfFaceName) <> 0 then
            FFontCharsetModified := True;
          UpdateFromLogFont(LogFont);
          if FFontColorModified then Font.Color := rgbColors;
        end;
      finally
        // zero out the logfont pointer, so we dont double-free it
        Marshal.WriteInt32(DialogData,
          Integer(Marshal.OffsetOf(TypeOf(TChooseFont), 'lpLogFont')), 0);
        Marshal.DestroyStructure(DialogData, TypeOf(TChooseFont));
      end;
    finally
      Marshal.DestroyStructure(Mem, TypeOf(TLogFont));
    end;
  end;
end;

procedure TFontDialog.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TFontDialog.UpdateFromLogFont(const LogFont: TLogFont);
var
  Style: TFontStyles;
begin
  with LogFont do
  begin
    Font.Name := LogFont.lfFaceName;
    Font.Height := LogFont.lfHeight;
    if FFontCharsetModified then
      Font.Charset := TFontCharset(LogFont.lfCharSet);
    Style := [];
    with LogFont do
    begin
      if lfWeight > FW_REGULAR then Include(Style, fsBold);
      if lfItalic <> 0 then Include(Style, fsItalic);
      if lfUnderline <> 0 then Include(Style, fsUnderline);
      if lfStrikeOut <> 0 then Include(Style, fsStrikeOut);
    end;
    Font.Style := Style;
  end;
end;

{ Printer dialog routines }

procedure GetPrinter(var DeviceMode, DeviceNames: HGLOBAL);
var
  Device, Driver, Port: string;
  DevMode, Ptr: IntPtr;
  DevModeRec: TDeviceMode;
  Len, StructLen: Integer;
  OffsetInChars, OffsetInBytes: Word;
  Temp, Buffer: TBytes;
  DevNameRec: TDevNames;
begin
  Printer.GetPrinter(Device, Driver, Port, DevMode);
  if DevMode <> nil then
  begin
    // first convert DevMode to a global handle
    // note we dont know the size of this, so we allocate the max
    DeviceMode := GlobalAlloc(GHND, SizeOf(TDeviceMode) +
      (CCHDEVICENAME + CCHFORMNAME) * Marshal.SystemDefaultCharSize);
    Ptr := GlobalLock(DeviceMode);
    try
      DevModeRec := TDeviceMode(Marshal.PtrToStructure(DevMode, TypeOf(TDeviceMode)));
      Marshal.StructureToPtr(TObject(DevModeRec), Ptr, False);
    finally
      GlobalUnlock(DeviceMode);
    end;

    // now assemble DeviceNames

    // add null terminators
    Len := Length(Driver) + 1;
    SetLength(Driver, Len);
    Driver[Len] := #0;
    Len := Length(Device) + 1;
    SetLength(Device, Len);
    Device[Len] := #0;
    Len := Length(Port) + 1;
    SetLength(Port, Len);
    Port[Len] := #0;

    // allocate a buffer to hold the device names we will write to memory

    StructLen := (Length(Device) + Length(Driver) + Length(Port)) * Marshal.SystemDefaultCharSize;
    SetLength(Buffer, StructLen);

    // now fill buffer with the necessary bytes

    OffsetInBytes := 0;
    OffsetInChars := 0;
    // wDriverOffset and Driver string
    DevNameRec.wDriverOffset := OffsetInChars;
    Temp := PlatformBytesOf(Driver);
    Len := Length(Temp);
    System.Array.Copy(Temp, 0, Buffer, OffsetInBytes, Len);
    Inc(OffsetInBytes, Len);
    Inc(OffsetInChars, Len div Marshal.SystemDefaultCharSize);
    // wDeviceOffset and Device string
    DevNameRec.wDeviceOffset := OffsetInChars;
    Temp := PlatformBytesOf(Device);
    Len := Length(Temp);
    System.Array.Copy(Temp, 0, Buffer, OffsetInBytes, Len);
    Inc(OffsetInBytes, Len);
    Inc(OffsetInChars, Len div Marshal.SystemDefaultCharSize);
    // wOutputOffset and Port string
    DevNameRec.wOutputOffset := OffsetInChars;
    Temp := PlatformBytesOf(Port);
    System.Array.Copy(Temp, 0, Buffer, OffsetInBytes, Length(Temp));

    // finally, allocate DeviceNames and write the buffer

    DeviceNames := GlobalAlloc(GHND, StructLen + Marshal.SizeOf(TypeOf(TDevNames)));
    Ptr := GlobalLock(DeviceNames);
    try
      Marshal.StructureToPtr(TObject(DevNameRec), Ptr, False);
      Ptr := IntPtr(Integer(Ptr) + Marshal.SizeOf(TypeOf(TDevNames)));
      Marshal.Copy(Buffer, 0, Ptr, StructLen);
    finally
      GlobalUnlock(DeviceNames);
    end;
  end;
end;

procedure SetPrinter(DeviceMode, DeviceNames: HGLOBAL);
var
  Device, Driver, Port: string;
  Offset: Integer;
  DevNames, DevMode, Ptr: IntPtr;
  DevModeRec: TDeviceMode;
  DevNameRec: TDevNames;
begin
  try
    // first copy the DevMode
    DevMode := Marshal.AllocHGlobal(GlobalSize(DeviceMode));
    try
      Ptr := GlobalLock(DeviceMode);
      try
        DevModeRec := TDeviceMode(Marshal.PtrToStructure(Ptr, TypeOf(TDeviceMode)));
        Marshal.StructureToPtr(TObject(DevModeRec), DevMode, False);
      finally
        GlobalUnlock(DeviceMode);
      end;
    except
      Marshal.FreeHGlobal(DevMode);
      DevMode := nil;
    end;

    // now decipher the devicenames
    DevNames := GlobalLock(DeviceNames);
    try
      DevNameRec := TDevNames(Marshal.PtrToStructure(DevNames, TypeOf(TDevNames)));
      Offset := (DevNameRec.wDriverOffset * Marshal.SystemDefaultCharSize) + Integer(DevNames);
      Ptr := IntPtr.Create(Offset);
      Driver := Marshal.PtrToStringAuto(Ptr);
      Offset := (DevNameRec.wDeviceOffset * Marshal.SystemDefaultCharSize) + Integer(DevNames);
      Ptr := IntPtr.Create(Offset);
      Device := Marshal.PtrToStringAuto(Ptr);
      Offset := (DevNameRec.wOutputOffset * Marshal.SystemDefaultCharSize) + Integer(DevNames);
      Ptr := IntPtr.Create(Offset);
      Port := Marshal.PtrToStringAuto(Ptr);
    finally
      GlobalUnlock(DeviceNames);
    end;
    // pass the copied information to the printer
    Printer.SetPrinter(Device, Driver, Port, DevMode);
  finally
    GlobalFree(DeviceNames);
    GlobalFree(DeviceMode);
  end;
end;

function CopyDeviceMode(Src: HGLOBAL): HGLOBAL;
var
  Temp: TDeviceMode;
  SrcPtr, DestPtr: IntPtr;
begin
  if Src <> 0 then
  begin
    Result := GlobalAlloc(GHND, GlobalSize(Src));
    if Result <> 0 then
    SrcPtr := GlobalLock(Src);
    try
      DestPtr := GlobalLock(Result);
      try
        Temp := TDeviceMode(Marshal.PtrToStructure(SrcPtr, TypeOf(TDeviceMode)));
        Marshal.StructureToPtr(TObject(Temp), DestPtr, False);
      finally
        GlobalUnlock(Result);
      end;
    finally
      GlobalUnlock(Src);
    end;
  end else
    Result := 0;
end;

{ TPrinterSetupDialog }
function TPrinterSetupDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  Result := PrintDlg(DialogData);
end;

function TPrinterSetupDialog.Execute(ParentWnd: HWND): Boolean;
var
  PrintDlgRec: TPrintDlg;
  DevHandle: HGLOBAL;
  DialogData: IntPtr;
begin
  with PrintDlgRec do
  begin
    lStructSize := Marshal.SizeOf(TypeOf(TPrintDlg));
    hInstance := WinUtils.HInstance;
    GetPrinter(DevHandle, hDevNames);
    hDevMode := CopyDeviceMode(DevHandle);
    Flags := PD_ENABLESETUPHOOK or PD_PRINTSETUP;
    lpfnSetupHook := FDialogHookDelegate;
    FRedirector := TRedirectorWindow.Create(nil);
    with TRedirectorWindow(FRedirector) do
    begin
      FCommonDialog := Self;
      FFormHandle := ParentWnd;
    end;
    hWndOwner := FRedirector.Handle;
  end;
  DialogData := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TPrintDlg)));
  try
    Marshal.StructureToPtr(TObject(PrintDlgRec), DialogData, False);
    Result := TaskModalDialog(DialogData);
    PrintDlgRec := TPrintDlg(Marshal.PtrToStructure(DialogData, TypeOf(TPrintDlg)));
  finally
    Marshal.DestroyStructure(DialogData, TypeOf(TPrintDlg));
  end;
  with PrintDlgRec do
  begin
    if Result then
      SetPrinter(hDevMode, hDevNames)
    else begin
      if hDevMode <> 0 then
      begin
        GlobalFree(hDevMode);
        hDevMode := 0;
      end;
      if hDevNames <> 0 then
      begin
        GlobalFree(hDevNames);
        hDevNames := 0;
      end;
    end;
  end;
end;
{ TPrintDialog }

procedure TPrintDialog.SetNumCopies(Value: Integer);
begin
  FCopies := Value;
  Printer.Copies := Value;
end;

function TPrintDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  Result := PrintDlg(DialogData);
end;

function TPrintDialog.Execute(ParentWnd: HWND): Boolean;
const
  PrintRanges: array[TPrintRange] of Integer =
    (PD_ALLPAGES, PD_SELECTION, PD_PAGENUMS);
var
  PrintDlgRec: TPrintDlg;
  DevHandle: HGLOBAL;
  DialogData: IntPtr;
begin
  with PrintDlgRec do
  begin
    lStructSize := Marshal.SizeOf(TypeOf(TPrintDlg));
    hInstance := WinUtils.HInstance;
    GetPrinter(DevHandle, hDevNames);
    hDevMode := CopyDeviceMode(DevHandle);
    Flags := PrintRanges[FPrintRange] or (PD_ENABLEPRINTHOOK or
      PD_ENABLESETUPHOOK);
    if FCollate then Inc(Flags, PD_COLLATE);
    if not (poPrintToFile in FOptions) then Inc(Flags, PD_HIDEPRINTTOFILE);
    if not (poPageNums in FOptions) then Inc(Flags, PD_NOPAGENUMS);
    if not (poSelection in FOptions) then Inc(Flags, PD_NOSELECTION);
    if poDisablePrintToFile in FOptions then Inc(Flags, PD_DISABLEPRINTTOFILE);
    if FPrintToFile then Inc(Flags, PD_PRINTTOFILE);
    if poHelp in FOptions then Inc(Flags, PD_SHOWHELP);
    if not (poWarning in FOptions) then Inc(Flags, PD_NOWARNING);
    if Length(Template) > 0 then
    begin
      Flags := Flags or PD_ENABLEPRINTTEMPLATE;
      lpPrintTemplateName := Template;
      if FTemplateModule <> 0 then
        hInstance := FTemplateModule;
    end;
    nFromPage := FFromPage;
    nToPage := FToPage;
    nMinPage := FMinPage;
    nMaxPage := FMaxPage;
    lpfnPrintHook := FDialogHookDelegate;
    lpfnSetupHook := FDialogHookDelegate;
    FRedirector := TRedirectorWindow.Create(nil);
    with TRedirectorWindow(FRedirector) do
    begin
      FCommonDialog := Self;
      FFormHandle := ParentWnd;
    end;
    hWndOwner := FRedirector.Handle;
  end;
  DialogData := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TPrintDlg)));
  try
    Marshal.StructureToPtr(TObject(PrintDlgRec), DialogData, False);
    Result := TaskModalDialog(DialogData);
    PrintDlgRec := TPrintDlg(Marshal.PtrToStructure(DialogData, TypeOf(TPrintDlg)));
  finally
    Marshal.DestroyStructure(DialogData, TypeOf(TPrintDlg));
  end;
  with PrintDlgRec do
  begin
    if Result then
    begin
      SetPrinter(hDevMode, hDevNames);
      FCollate := Flags and PD_COLLATE <> 0;
      FPrintToFile := Flags and PD_PRINTTOFILE <> 0;
      if Flags and PD_SELECTION <> 0 then FPrintRange := prSelection else
        if Flags and PD_PAGENUMS <> 0 then FPrintRange := prPageNums else
          FPrintRange := prAllPages;
      FFromPage := nFromPage;
      FToPage := nToPage;
      if nCopies = 1 then
        Copies := Printer.Copies else
        Copies := nCopies;
    end
    else begin
      if hDevMode <> 0 then
      begin
        GlobalFree(hDevMode);
        hDevMode := 0;
      end;
      if hDevNames <> 0 then
      begin
        GlobalFree(hDevNames);
        hDevNames := 0;
      end;
    end;
  end;
end;
{ TPageSetupDialog }

const
  PageType: array[Boolean] of TPageType = (ptEnvelope, ptPaper);
  Orientation: array[Boolean] of TPrinterOrientation = (poPortrait, poLandscape);

function TPageSetupDialog.PagePaint(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT;
var
  DoneDrawing: Boolean;

  procedure CallPaintEvent(Event: TPaintPageEvent);
  var
    Canvas: TCanvas;
    Rect: TRect;
  begin
    Canvas := TCanvas.Create;
    try
      Canvas.Handle := HDC(wParam);
      if Assigned(Event) then
      begin
        Rect := TRect(Marshal.PtrToStructure(IntPtr(lParam), TypeOf(TRect)));
        Event(self, Canvas, Rect, DoneDrawing);
      end;
    finally
      Canvas.Free;
    end;
  end;

begin
  DoneDrawing := False;
  if Message = WM_PSD_PAGESETUPDLG then
  begin
    if Assigned(FBeforePaint) then
      // Constants used below are from WinAPI help on WM_PSD_PAGESETUPDLG
      BeforePaint(self, (wParam and $FFFF),
        Orientation[(wParam shr 16) in [$0001,$0003, $000B, $0019]],
        PageType[(wParam shr 16) > $000B], DoneDrawing);
  end
  else
    case Message of
      WM_PSD_FULLPAGERECT  : CallPaintEvent(FOnDrawFullPage);
      WM_PSD_MINMARGINRECT : CallPaintEvent(FOnDrawMinMargin);
      WM_PSD_MARGINRECT    : CallPaintEvent(FOnDrawMargin);
      WM_PSD_GREEKTEXTRECT : CallPaintEvent(FOnDrawGreekText);
      WM_PSD_ENVSTAMPRECT  : CallPaintEvent(FOnDrawEnvStamp);
      WM_PSD_YAFULLPAGERECT: CallPaintEvent(FOnDrawRetAddress);
    end;
  Result := UINT(DoneDrawing);
end;

constructor TPageSetupDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Options := [psoDefaultMinMargins];
  GetDefaults;
end;

function TPageSetupDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  Result := PageSetupDlg(DialogData);
end;

function TPageSetupDialog.Execute(ParentWnd: HWND): Boolean;
var
  DialogData: IntPtr;
begin
  with FPageSetupDlgRec do
  begin
    lStructSize := Marshal.SizeOf(TypeOf(TPageSetupDlg));
    FRedirector := TRedirectorWindow.Create(nil);
    with TRedirectorWindow(FRedirector) do
    begin
      FCommonDialog := Self;
      FFormHandle := ParentWnd;
    end;
    hWndOwner := FRedirector.Handle;
    hInstance := WinUtils.HInstance;
    {these must be 0 for the PSD_RETURNDEFAULT call to work}
//    GetPrinter(DevHandle, hDevNames);
//    hDevMode := CopyDeviceMode(DevHandle);
    hDevNames := 0;
    hDevMode := 0;
    Flags := PSD_RETURNDEFAULT;
    PageSetupDlg(FPageSetupDlgRec);
    Flags := PSD_ENABLEPAGEPAINTHOOK or PSD_ENABLEPAGESETUPHOOK or PSD_MARGINS;
    case FUnits of
//    pmDefault    : Read from locale settings by the dialog
      pmInches     : Inc(Flags, PSD_INTHOUSANDTHSOFINCHES);
      pmMillimeters: Inc(Flags, PSD_INHUNDREDTHSOFMILLIMETERS);
    end;
    if psoDefaultMinMargins in FOptions then Inc(Flags, PSD_DEFAULTMINMARGINS);
    if psoDisableMargins in FOptions then Inc(Flags, PSD_DisableMargins);
    if psoDisableOrientation in FOptions then Inc(Flags, PSD_DISABLEORIENTATION);
    if psoDisablePagePainting in FOptions then
      Inc(Flags, PSD_DISABLEPAGEPAINTING)
    else
      lpfnPagePaintHook := PagePaint; { TFNCommDlgHook }
    if psoDisablePaper in FOptions then Inc(Flags, PSD_DISABLEPAPER);
    if psoDisablePrinter in FOptions then Inc(Flags, PSD_DISABLEPRINTER);
    if psoMargins in FOptions then Inc(Flags, PSD_MARGINS);
    if psoMinMargins in FOptions then Inc(Flags, PSD_MINMARGINS);
    if psoShowHelp in FOptions then Inc(Flags, PSD_SHOWHELP);
    if not (psoWarning in FOptions) then Inc(Flags, PSD_NOWARNING);
    if psoNoNetworkButton in FOptions then Inc(Flags, PSD_NONETWORKBUTTON);
    ptPaperSize := Point(FPageWidth, FPageHeight);
    rtMinMargin := Types.Rect(FMinMarginLeft, FMinMarginTop, FMinMarginRight, FMinMarginBottom);
    rtMargin := Types.Rect(FMarginLeft, FMarginTop, FMarginRight, FMarginBottom);
    lpfnPageSetupHook := FDialogHookDelegate;
  end;
  DialogData := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(TPageSetupDlg)));
  try
    Marshal.StructureToPtr(TObject(FPageSetupDlgRec), DialogData, False);
    Result := TaskModalDialog(DialogData);
    FPageSetupDlgRec := TPageSetupDlg(Marshal.PtrToStructure(DialogData,
      TypeOf(TPageSetupDlg)));
  finally
    Marshal.DestroyStructure(DialogData, TypeOf(TPageSetupDlg));
  end;
  with FPageSetupDlgRec do
  begin
    if Result then
    begin
      PageWidth := ptPaperSize.x;
      PageHeight := ptPaperSize.y;
      MarginLeft := rtMargin.Left;
      MarginTop := rtMargin.Top;
      MarginRight := rtMargin.Right;
      MarginBottom := rtMargin.Bottom;
      SetPrinter(hDevMode, hDevNames)
    end
    else begin
      if hDevMode <> 0 then
      begin
        GlobalFree(hDevMode);
        hDevMode := 0;
      end;
      if hDevNames <> 0 then
      begin
        GlobalFree(hDevNames);
        hDevNames := 0;
      end;
     end;
  end;
end;

function TPageSetupDialog.GetDefaults: Boolean;
var
  PageSetupDlgRec: TPageSetupDlg;
begin
  Result := False;
  try
    Printer.PrinterIndex;  // raises an exception if there is no default printer
  except
    exit;
  end;
//  FillChar(PageSetupDlgRec, SizeOf(PageSetupDlgRec), 0);
  with PageSetupDlgRec do
  begin
    lStructSize := Marshal.SizeOf(TypeOf(TPageSetupDlg));
    hwndOwner := Application.Handle;
    hInstance := WinUtils.HInstance;
    case FUnits of
//    pmDefault    : Read from locale settings by the dialog
      pmInches     : Inc(Flags, PSD_INTHOUSANDTHSOFINCHES);
      pmMillimeters: Inc(Flags, PSD_INHUNDREDTHSOFMILLIMETERS);
    end;
    if psoDefaultMinMargins in FOptions then Inc(Flags, PSD_DEFAULTMINMARGINS);
    if psoDisableMargins in FOptions then Inc(Flags, PSD_DISABLEMARGINS);
    if psoDisableOrientation in FOptions then Inc(Flags, PSD_DISABLEORIENTATION);
    if psoDisablePagePainting in FOptions then
      Inc(Flags, PSD_DISABLEPAGEPAINTING);
    if psoDisablePaper in FOptions then Inc(Flags, PSD_DISABLEPAPER);
    if psoDisablePrinter in FOptions then Inc(Flags, PSD_DISABLEPRINTER);
    ptPaperSize := Point(FPageWidth, FPageHeight);
    rtMinMargin := Types.Rect(FMinMarginLeft, FMinMarginTop, FMinMarginRight, FMinMarginBottom);
    rtMargin := Types.Rect(FMarginLeft, FMarginTop, FMarginRight, FMarginBottom);
    lpfnPageSetupHook := FDialogHookDelegate;

    Flags := Flags or PSD_RETURNDEFAULT;
    hDevNames := 0;
    hDevMode := 0;
    Result := PageSetupDlg(PageSetupDlgRec);

    if Result then
    begin
      FPageWidth := ptPaperSize.x;
      FPageHeight := ptPaperSize.y;
      FMarginLeft := rtMargin.Left;
      FMarginTop := rtMargin.Top;
      FMarginRight := rtMargin.Right;
      FMarginBottom := rtMargin.Bottom;
      if hDevMode <> 0 then
      begin
        GlobalFree(hDevMode);
        hDevMode := 0;
      end;
      if hDevNames <> 0 then
      begin
        GlobalFree(hDevNames);
        hDevNames := 0;
      end;
    end;
  end;
end;

{ Find and Replace dialog routines }

procedure TFindDlgResources.Finalize;
var
  FR: TFindReplace;
begin
  if FFindHandle <> 0 then
  begin
    DestroyWindow(FFindHandle);
    FFindHandle := 0;
  end;
  if FFindReplacePtr <> nil then
  begin
    FR := TFindReplace(Marshal.PtrToStructure(FFindReplacePtr, TypeOf(TFindReplace)));
    if FR.lpstrFindWhat <> nil then
      Marshal.FreeHGlobal(FR.lpstrFindWhat);
    if FR.lpstrReplaceWith <> nil then
      Marshal.FreeHGlobal(FR.lpstrReplaceWith);
    Marshal.FreeHGlobal(FFindReplacePtr);
    FFindReplacePtr := nil;
  end;
  if Assigned(FObjectInstance) then
  begin
    WinUtils.FreeObjectInstance(FObjectInstance);
    FObjectInstance := nil;
  end;
end;

function TFindDialog.FindReplaceWndProc(Wnd: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT;
var
  FR: TFindReplace;
begin
  case Msg of
    WM_DESTROY:
      if Application.DialogHandle = Wnd then Application.DialogHandle := 0;
    WM_NCACTIVATE:
      if WParam <> 0 then
      begin
        if Application.DialogHandle = 0 then Application.DialogHandle := Wnd;
      end else
      begin
        if Application.DialogHandle = Wnd then Application.DialogHandle := 0;
      end;
    WM_NCDESTROY:
      begin
        Result := CallWindowProc(FOldWindowLong, Wnd, Msg, WParam, LParam);
        // cleanup
        FResources.FFindHandle := 0;
        FOldWindowLong := IntPtr(Integer(0));
        if Assigned(FResources.FObjectInstance) then
        begin
          WinUtils.FreeObjectInstance(FResources.FObjectInstance);
          FResources.FObjectInstance := nil;
          FObjectInstance := nil;
        end;
        if FResources.FFindReplacePtr <> nil then
        begin
          FR := TFindReplace(Marshal.PtrToStructure(FResources.FFindReplacePtr,
             TypeOf(TFindReplace)));
          if FR.lpstrFindWhat <> nil then
          begin
            FindText := Marshal.PtrToStringAuto(FR.lpstrFindWhat);
            Marshal.FreeHGlobal(FR.lpstrFindWhat);
          end;
          if FR.lpstrReplaceWith <> nil then
          begin
            ReplaceText := Marshal.PtrToStringAuto(FR.lpstrReplaceWith);
            Marshal.FreeHGlobal(FR.lpstrReplaceWith);
          end;
          Marshal.FreeHGlobal(FResources.FFindReplacePtr);
          FResources.FFindReplacePtr := nil;
        end;
        System.GC.SuppressFinalize(FResources);
        FreeAndNil(FResources);
        Exit;
      end;
   end;
   Result := CallWindowProc(FOldWindowLong, Wnd, Msg, WParam, LParam);
end;

function TFindDialog.FindReplaceDialogHook(Wnd: HWnd; Msg: UINT; WParam: WPARAM; LParam: LPARAM): UINT;
begin
  Result := DialogHook(Wnd, Msg, wParam, lParam);
  if Msg = WM_INITDIALOG then
  begin
    if (Left <> -1) or (Top <> -1) then
        SetWindowPos(Wnd, 0, Left, Top, 0, 0, SWP_NOACTIVATE or
          SWP_NOSIZE or SWP_NOZORDER);
    FOldWindowLong := SetWindowLong(Wnd, GWL_WNDPROC, FFRWP);
    Result := 1;
  end;
end;

const
  FindOptions: array[TFindOption] of DWORD = (
    FR_DOWN, FR_FINDNEXT, FR_HIDEMATCHCASE, FR_HIDEWHOLEWORD,
    FR_HIDEUPDOWN, FR_MATCHCASE, FR_NOMATCHCASE, FR_NOUPDOWN, FR_NOWHOLEWORD,
    FR_REPLACE, FR_REPLACEALL, FR_WHOLEWORD, FR_SHOWHELP);

{ TFindDialog }

const FindReplaceStringLen = 256;

constructor TFindDialog.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FOptions := [frDown];
  FPosition.X := -1;
  FPosition.Y := -1;
  FFindText := '';
  FReplaceText := '';
  FFRDH := @FindReplaceDialogHook;
  FFRWP := @FindReplaceWndProc;
end;

function TFindDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  if Assigned(FResources) then
  begin
    FResources.FFindHandle := CommDlg.FindText(DialogData);
    Result := FResources.FFindHandle <> 0;
  end else
    Result := False;
end;

destructor TFindDialog.Destroy;
var
  FR: TFindReplace;
begin
  if Assigned(FResources) and (FResources.FFindHandle <> 0) then
  begin
    SendMessage(FResources.FFindHandle, WM_CLOSE, 0, 0);
    FResources.FFindHandle := 0;
  end;
  if Assigned(FResources) then
  begin
    if FResources.FFindReplacePtr <> nil then
    begin
      FR := TFindReplace(Marshal.PtrToStructure(FResources.FFindReplacePtr, TypeOf(TFindReplace)));
      if FR.lpstrFindWhat <> nil then
        Marshal.FreeHGlobal(FR.lpstrFindWhat);
      if FR.lpstrReplaceWith <> nil then
        Marshal.FreeHGlobal(FR.lpstrReplaceWith);
      Marshal.FreeHGlobal(FResources.FFindReplacePtr);
      FResources.FFindReplacePtr := nil;
    end;
    if Assigned(FResources.FObjectInstance) then
    begin
      WinUtils.FreeObjectInstance(FResources.FObjectInstance);
      FResources.FObjectInstance := nil;
      FObjectInstance := nil;
    end;
    System.GC.SuppressFinalize(FResources);
    FreeAndNil(FResources);
  end;
  inherited Destroy;
end;

procedure TFindDialog.CloseDialog;
begin
  if Assigned(FResources) and (FResources.FFindHandle <> 0) then
    PostMessage(FResources.FFindHandle, WM_CLOSE, 0, 0);
end;

function GetTopWindow(Wnd: HWND; Mem: LParam):Bool;
var
  Test: TWinControl;
begin
  Test := FindControl(Wnd);
  Result := True;
  if Assigned(Test) and (Test is TForm) then
  begin
    Marshal.WriteInt32(IntPtr(Mem), Wnd);
    Result := False;
  end;
end;

procedure WriteStringToPtr(Ptr: IntPtr; S: string);
var
  Bytes: TBytes;
begin
  if (Length(S) = 0) or (S[Length(S)] <> #0) then // make sure string is null terminated
    S := S + #0;
  Bytes := PlatformBytesOf(S);
  Marshal.Copy(Bytes, 0, Ptr, Length(Bytes));
end;

function TFindDialog.Execute(ParentWnd: HWND): Boolean;
var
  Option: TFindOption;
  Mem: IntPtr;
  EnumProc: TFNWndEnumProc;
  FR : TFindReplace;
begin
  if not Assigned(FResources) then
    FResources := TFindDlgResources.Create;
  if FResources.FFindHandle <> 0 then
  begin
    BringWindowToTop(FResources.FFindHandle);
    Result := True;
  end else
  begin
    if not Assigned(FResources.FObjectInstance) then
    begin
      FResources.FObjectInstance := WinUtils.MakeObjectInstance(MainWndProc);
      FObjectInstance := FResources.FObjectInstance;
    end;
    with FR do
    begin
      lStructSize := Marshal.SizeOf(TypeOf(TFindReplace));
      hInstance := WinUtils.HInstance;
      lCustData := 0;
      lpfnHook := FFRDH;
      FRedirector := TRedirectorWindow.Create(nil);
      with TRedirectorWindow(FRedirector) do
      begin
        FCommonDialog := Self;
        EnumProc := @GetTopWindow; // save a reference to the delegate
        Mem := Marshal.AllocHGlobal(SizeOf(FFormHandle));
        try
          Marshal.WriteInt32(Mem, FFormHandle);
          EnumThreadWindows(GetCurrentThreadID, EnumProc, LongInt(Mem));
          FFormHandle := Marshal.ReadInt32(Mem);
        finally
          Marshal.FreeHGlobal(Mem);
        end;
      end;
      hWndOwner := FRedirector.Handle;
      Flags := FR_ENABLEHOOK;
      for Option := Low(Option) to High(Option) do
      if Option in FOptions then
        Flags := Flags or FindOptions[Option];
      if Length(Template) > 0 then
      begin
        Flags := Flags or FR_ENABLETEMPLATE;
        lpTemplateName := Template;
        if FTemplateModule <> 0 then
          hInstance := FTemplateModule;
      end;
      wFindWhatLen := FindReplaceStringLen * sizeOf(Char);
      wReplaceWithLen := wFindWhatLen;
      lpstrFindWhat := Marshal.AllocHGlobal(wFindWhatLen);
      try
        WriteStringToPtr(lpstrFindWhat, FFindText);
        lpstrReplaceWith := Marshal.AllocHGlobal(wReplaceWithLen);
        try
          WriteStringToPtr(lpstrReplaceWith, FReplaceText);
        except
          Marshal.FreeHGlobal(lpstrReplaceWith);
          lpstrReplaceWith := nil;
          raise;
        end;
      except
        Marshal.FreeHGlobal(lpstrFindWhat);
        lpstrFindWhat := nil;
        raise;
      end;
    end;
    FResources.FFindReplacePtr := Marshal.AllocHGlobal(FR.lStructSize);
    try
      Marshal.StructureToPtr(TObject(FR), FResources.FFindReplacePtr, False);
      Result := LaunchDialog(FResources.FFindReplacePtr);
    except
      if FResources.FFindReplacePtr <> nil then
      begin
        if FR.lpstrFindWhat <> nil then
          Marshal.FreeHGlobal(FR.lpstrFindWhat);
        if FR.lpstrReplaceWith <> nil then
          Marshal.FreeHGlobal(FR.lpstrReplaceWith);
        Marshal.FreeHGlobal(FResources.FFindReplacePtr);
        FResources.FFindReplacePtr := nil;
      end;
      raise;
    end;
  end;
end;

procedure TFindDialog.Find;
begin
  if Assigned(FOnFind) then FOnFind(Self);
end;

function TFindDialog.GetFindText: string;
begin
  Result := FFindText;
end;

function TFindDialog.GetLeft: Integer;
begin
  Result := Position.X;
end;

function TFindDialog.GetPosition: TPoint;
var
  Rect: TRect;
begin
  Result := FPosition;
  if Assigned(FResources) and (FResources.FFindHandle <> 0) then
  begin
    GetWindowRect(FResources.FFindHandle, Rect);
    Result := Rect.TopLeft;
  end;
end;

function TFindDialog.GetReplaceText: string;
begin
  Result := FReplaceText;
end;

function TFindDialog.GetTop: Integer;
begin
  Result := Position.Y;
end;

function TFindDialog.MessageHook(var Msg: TMessage): Boolean;
var
  Option: TFindOption;
  Rect: TRect;
  FR: TFindReplace;
begin
  Result := inherited MessageHook(Msg);
  if not Result then
     if (Msg.Msg = Integer(FindMsg)) then
    begin
      FR := TFindReplace(Marshal.PtrToStructure(IntPtr(Msg.LParam),
        Typeof(TFindReplace)));
      FFindText := Marshal.PtrToStringAuto(FR.lpstrFindWhat);
      FReplaceText := Marshal.PtrToStringAuto(FR.lpstrReplaceWith);
      FOptions := [];
      for Option := Low(Option) to High(Option) do
        if (FR.Flags and FindOptions[Option]) <> 0 then
          Include(FOptions, Option);
      if (FR.Flags and FR_FINDNEXT) <> 0 then
        Find
      else
      if (FR.Flags and (FR_REPLACE or FR_REPLACEALL)) <> 0 then
        Replace
      else
      if (FR.Flags and FR_DIALOGTERM) <> 0 then
      begin
        if Assigned(FResources) then
        begin
          GetWindowRect(FResources.FFindHandle, Rect);
          FPosition := Rect.TopLeft;
          FResources.FFindHandle := 0;
        end;
        PostMessage(FRedirector.Handle,CM_RELEASE,0,0); // free redirector later
        FRedirector := nil;
      end;
      Result := True;
    end;
  end;

procedure TFindDialog.Replace;
begin
  if Assigned(FOnReplace) then FOnReplace(Self);
end;

procedure TFindDialog.SetFindText(const Value: string);
begin
  FFindText := Value;
end;

procedure TFindDialog.SetLeft(Value: Integer);
begin
  SetPosition(Point(Value, Top));
end;

procedure TFindDialog.SetPosition(const Value: TPoint);
begin
  if (FPosition.X <> Value.X) or (FPosition.Y <> Value.Y) then
  begin
    FPosition := Value;
    if Assigned(FResources) and (FResources.FFindHandle <> 0) then
      SetWindowPos(FResources.FFindHandle, 0, Value.X, Value.Y, 0, 0,
        SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
  end;
end;

procedure TFindDialog.SetReplaceText(const Value: string);
begin
  FReplaceText := Value;
end;

procedure TFindDialog.SetTop(Value: Integer);
begin
  SetPosition(Point(Left, Value));
end;

{ TReplaceDialog }

function TReplaceDialog.LaunchDialog(DialogData: IntPtr): Bool;
begin
  if Assigned(FResources) then
  begin
    FResources.FFindHandle := CommDlg.ReplaceText(DialogData);
    Result := FResources.FFindHandle <> 0;
  end else
    Result := False;
end;

{ Message dialog }

function GetAveCharSize(Canvas: TCanvas): TPoint;
var
  I: Integer;
  Buffer: string;
  Size: TSize;
begin
  SetLength(Buffer, 52);
  for I := 0 to 25 do Buffer[I + 1] := Chr(I + Ord('A'));
  for I := 0 to 25 do Buffer[I + 27] := Chr(I + Ord('a'));
  GetTextExtentPoint(Canvas.Handle, Buffer, 52, Size);
  Result.X := Size.cx div 52;
  Result.Y := Size.cy;
end;

type
  TMessageForm = class(TForm)
  private
    Message: TLabel;
    procedure HelpButtonClick(Sender: TObject);
  protected
    procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure WriteToClipBoard(Text: String);
    function GetFormText: String;
  public
    constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
  end;

constructor TMessageForm.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
var
  NonClientMetrics: TNonClientMetrics;
  NCMSize: Integer;
  Mem: IntPtr;
begin
  inherited CreateNew(AOwner, Dummy);
 {Note, we must allocate our own memory using Marshal's SizeOf below,
  because we need to take into account the size of string buffers. }
  NCMSize := Marshal.SizeOf(TypeOf(TNonClientMetrics));
  Mem := Marshal.AllocHGlobal(NCMSize);
  try
    Marshal.WriteInt32(Mem, NCMSize); // fill in the cbSize field
    if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NCMSize, Mem, 0) then
    begin
      NonClientMetrics := TNonClientMetrics(Marshal.PtrToStructure(Mem,
        TypeOf(TNonClientMetrics)));
      Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);
    end;
  finally
    System.Runtime.InteropServices.Marshal.FreeHGlobal(Mem);
  end;
end;

procedure TMessageForm.HelpButtonClick(Sender: TObject);
begin
  Application.HelpContext(HelpContext);
end;

procedure TMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if (Shift = [ssCtrl]) and (Key = Word('C')) then
  begin
    Beep;
    WriteToClipBoard(GetFormText);
  end;
end;

procedure TMessageForm.WriteToClipBoard(Text: String);
var
  Data: HGLOBAL;
  DataPtr: IntPtr;
  Buffer: TBytes;
begin
  if OpenClipBoard(0) then
  begin
    try
      Buffer := PlatformBytesOf(Text);
      SetLength(Buffer, Length(Buffer) + Marshal.SystemDefaultCharSize);
      Data := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, Length(Buffer));
      try
        DataPtr := GlobalLock(Data);
        try
          Marshal.Copy(Buffer, 0, DataPtr, Length(Buffer));
         finally
          GlobalUnlock(Data);
         end;
         EmptyClipBoard;
         if Marshal.SystemDefaultCharSize > 1 then
           SetClipboardData(CF_UNICODETEXT, Data)
         else
           SetClipboardData(CF_TEXT, Data)
      except
        GlobalFree(Data);
        raise;
      end;
    finally
      CloseClipBoard;
    end;
  end
  else
    raise Exception.Create(SCannotOpenClipboard);
end;

function TMessageForm.GetFormText: String;
var
  DividerLine, ButtonCaptions: string;
  I: integer;
begin
  DividerLine := StringOfChar('-', 27) + sLineBreak;
  for I := 0 to ComponentCount - 1 do
    if Components[I] is TButton then
      ButtonCaptions := ButtonCaptions + TButton(Components[I]).Caption +
        StringOfChar(' ', 3);
  ButtonCaptions := StringReplace(ButtonCaptions,'&','', [rfReplaceAll]);
  Result := Format('%s%s%s%s%s%s%s%s%s%s', [DividerLine, Caption, sLineBreak,
    DividerLine, Message.Caption, sLineBreak, DividerLine, ButtonCaptions,
    sLineBreak, DividerLine]);
end;

var
  Captions: array[TMsgDlgType] of string = (SMsgDlgWarning, SMsgDlgError,
    SMsgDlgInformation, SMsgDlgConfirm, '');
  IconIDs: array[TMsgDlgType] of Integer = (IDI_EXCLAMATION, IDI_HAND,
    IDI_ASTERISK, IDI_QUESTION, -1);
  ButtonNames: array[TMsgDlgBtn] of string = (
    'Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll',
    'YesToAll', 'Help');
  ButtonCaptions: array[TMsgDlgBtn] of string = (
    SMsgDlgYes, SMsgDlgNo, SMsgDlgOK, SMsgDlgCancel, SMsgDlgAbort,
    SMsgDlgRetry, SMsgDlgIgnore, SMsgDlgAll, SMsgDlgNoToAll, SMsgDlgYesToAll,
    SMsgDlgHelp);
  ModalResults: array[TMsgDlgBtn] of Integer = (
    mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll,
    mrYesToAll, 0);
  ButtonWidths : array[TMsgDlgBtn] of integer;  // initialized to zero

const
  mcHorzMargin = 8;
  mcVertMargin = 8;
  mcHorzSpacing = 10;
  mcVertSpacing = 10;
  mcButtonWidth = 50;
  mcButtonHeight = 14;
  mcButtonSpacing = 4;

function CreateMessageDialog(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons): TForm;
var
  DialogUnits: TPoint;
  HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth,
  ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth,
  IconTextWidth, IconTextHeight, X, ALeft: Integer;
  B, DefaultButton, CancelButton: TMsgDlgBtn;
  IconID: Integer;
  TextRect: TRect;
begin
  Result := TMessageForm.CreateNew(Application);
  with Result do
  begin
    BiDiMode := Application.BiDiMode;
    BorderStyle := bsDialog;
    Canvas.Font := Font;
    KeyPreview := True;
    Position := poDesigned;
    OnKeyDown := TMessageForm(Result).CustomKeyDown;
    DialogUnits := GetAveCharSize(Canvas);
    HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4);
    VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8);
    HorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4);
    VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8);
    ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4);
    for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
    begin
      if B in Buttons then
      begin
        if ButtonWidths[B] = 0 then
        begin
          TextRect := EmptyRect;
          Windows.DrawText( canvas.handle,
            ButtonCaptions[B], -1,
            TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or
            DrawTextBiDiModeFlagsReadingOnly);
          with TextRect do ButtonWidths[B] := Right - Left + 8;
        end;
        if ButtonWidths[B] > ButtonWidth then
          ButtonWidth := ButtonWidths[B];
      end;
    end;
    ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8);
    ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4);
    SetRect(TextRect, 0, 0, Screen.Width div 2, 0);
    DrawText(Canvas.Handle, Msg, Length(Msg)+1, TextRect,
      DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or
      DrawTextBiDiModeFlagsReadingOnly);
    IconID := IconIDs[DlgType];
    IconTextWidth := TextRect.Right;
    IconTextHeight := TextRect.Bottom;
    if DlgType <> mtCustom then
    begin
      Inc(IconTextWidth, 32 + HorzSpacing);
      if IconTextHeight < 32 then IconTextHeight := 32;
    end;
    ButtonCount := 0;
    for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
      if B in Buttons then Inc(ButtonCount);
    ButtonGroupWidth := 0;
    if ButtonCount <> 0 then
      ButtonGroupWidth := ButtonWidth * ButtonCount +
        ButtonSpacing * (ButtonCount - 1);
    ClientWidth := Max(IconTextWidth, ButtonGroupWidth) + HorzMargin * 2;
    ClientHeight := IconTextHeight + ButtonHeight + VertSpacing +
      VertMargin * 2;
    Left := (Screen.Width div 2) - (Width div 2);
    Top := (Screen.Height div 2) - (Height div 2);
    if DlgType <> mtCustom then
      Caption := Captions[DlgType] else
      Caption := Application.Title;
    if DlgType <> mtCustom then
      with TImage.Create(Result) do
      begin
        Name := 'Image';
        Parent := Result;
        Picture.Icon.Handle := LoadIcon(0, IconID);
        SetBounds(HorzMargin, VertMargin, 32, 32);
      end;
    TMessageForm(Result).Message := TLabel.Create(Result);
    with TMessageForm(Result).Message do
    begin
      Name := 'Message';
      Parent := Result;
      WordWrap := True;
      Caption := Msg;
      BoundsRect := TextRect;
      BiDiMode := Result.BiDiMode;
      ALeft := IconTextWidth - TextRect.Right + HorzMargin;
      if UseRightToLeftAlignment then
        ALeft := Result.ClientWidth - ALeft - Width;
      SetBounds(ALeft, VertMargin,
        TextRect.Right, TextRect.Bottom);
    end;
    if mbOk in Buttons then DefaultButton := mbOk else
      if mbYes in Buttons then DefaultButton := mbYes else
        DefaultButton := mbRetry;
    if mbCancel in Buttons then CancelButton := mbCancel else
      if mbNo in Buttons then CancelButton := mbNo else
        CancelButton := mbOk;
    X := (ClientWidth - ButtonGroupWidth) div 2;
    for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
      if B in Buttons then
        with TButton.Create(Result) do
        begin
          Name := ButtonNames[B];
          Parent := Result;
          Caption := ButtonCaptions[B];
          ModalResult := ModalResults[B];
          if B = DefaultButton then Default := True;
          if B = CancelButton then Cancel := True;
          SetBounds(X, IconTextHeight + VertMargin + VertSpacing,
            ButtonWidth, ButtonHeight);
          Inc(X, ButtonWidth + ButtonSpacing);
          if B = mbHelp then
            OnClick := TMessageForm(Result).HelpButtonClick;
        end;
  end;
end;

function MessageDlg(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
begin
  Result := MessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, -1, -1, '');
end;

function MessageDlgPos(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer;
begin
  Result := MessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx, X, Y, '');
end;

function MessageDlgPosHelp(const Msg: string; DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
  const HelpFileName: string): Integer;
begin
  with CreateMessageDialog(Msg, DlgType, Buttons) do
    try
      HelpContext := HelpCtx;
      HelpFile := HelpFileName;
      if X >= 0 then Left := X;
      if Y >= 0 then Top := Y;
      if (Y < 0) and (X < 0) then Position := poScreenCenter;
      Result := ShowModal;
    finally
      Free;
    end;
end;

procedure ShowMessage(const Msg: string);
begin
  ShowMessagePos(Msg, -1, -1);
end;

procedure ShowMessageFmt(const Msg: string; Params: array of const);
begin
  ShowMessage(Format(Msg, Params));
end;

procedure ShowMessagePos(const Msg: string; X, Y: Integer);
begin
  MessageDlgPos(Msg, mtCustom, [mbOK], 0, X, Y);
end;

{ Input dialog }

function InputQuery(const ACaption, APrompt: string;
  var Value: string): Boolean;
var
  Form: TForm;
  Prompt: TLabel;
  Edit: TEdit;
  DialogUnits: TPoint;
  ButtonTop, ButtonWidth, ButtonHeight: Integer;
begin
  Result := False;
  Form := TForm.Create(Application);
  with Form do
    try
      Canvas.Font := Font;
      DialogUnits := GetAveCharSize(Canvas);
      BorderStyle := bsDialog;
      Caption := ACaption;
      ClientWidth := MulDiv(180, DialogUnits.X, 4);
      Position := poScreenCenter;
      Prompt := TLabel.Create(Form);
      with Prompt do
      begin
        Parent := Form;
        Caption := APrompt;
        Left := MulDiv(8, DialogUnits.X, 4);
        Top := MulDiv(8, DialogUnits.Y, 8);
        Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4);
        WordWrap := True;
      end;
      Edit := TEdit.Create(Form);
      with Edit do
      begin
        Parent := Form;
        Left := Prompt.Left;
        Top := Prompt.Top + Prompt.Height + 5;
        Width := MulDiv(164, DialogUnits.X, 4);
        MaxLength := 255;
        Text := Value;
        SelectAll;
      end;
      ButtonTop := Edit.Top + Edit.Height + 15;
      ButtonWidth := MulDiv(50, DialogUnits.X, 4);
      ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := SMsgDlgOK;
        ModalResult := mrOk;
        Default := True;
        SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,
          ButtonHeight);
      end;
      with TButton.Create(Form) do
      begin
        Parent := Form;
        Caption := SMsgDlgCancel;
        ModalResult := mrCancel;
        Cancel := True;
        SetBounds(MulDiv(92, DialogUnits.X, 4), Edit.Top + Edit.Height + 15,
          ButtonWidth, ButtonHeight);
        Form.ClientHeight := Top + Height + 13;
      end;
      if ShowModal = mrOk then
      begin
        Value := Edit.Text;
        Result := True;
      end;
    finally
      Form.Free;
    end;
end;

function InputBox(const ACaption, APrompt, ADefault: string): string;
begin
  Result := ADefault;
  InputQuery(ACaption, APrompt, Result);
end;

function PromptForFileName(var AFileName: string; const AFilter: string = '';
  const ADefaultExt: string = ''; const ATitle: string = '';
  const AInitialDir: string = ''; SaveDialog: Boolean = False): Boolean;
var
  Dialog: TOpenDialog;
begin
  if SaveDialog then
  begin
    Dialog := TSaveDialog.Create(nil);
    Dialog.Options := Dialog.Options + [ofOverwritePrompt];
  end
  else
    Dialog := TOpenDialog.Create(nil);
  with Dialog do
  try
    Title := ATitle;
    DefaultExt := ADefaultExt;
    if AFilter = '' then
      Filter := SDefaultFilter else
      Filter := AFilter;
    InitialDir := AInitialDir;
    FileName := AFileName;
    Result := Execute;
    if Result then
      AFileName := FileName;
  finally
    Free;
  end;
end;

{ Initialization and cleanup }

procedure InitGlobals;
begin
  TCommonDialog.HelpMsg := RegisterWindowMessage(HelpMsgString);
  FindMsg := RegisterWindowMessage(FindMsgString);
end;

initialization
  InitGlobals;
  StartClassGroup(TControl);
  ActivateClassGroup(TControl);
  GroupDescendentsWith(TCommonDialog, TControl);
end.
