paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 01:28:17 +02:00
Code Issues Packages Projects Releases Wiki Activity
7cfdbd74c8
lazarus/lcl/interfaces/win32/win32wsdialogs.pp

2140 lines
73 KiB
ObjectPascal
Raw Blame History

{ $Id$}
{
*****************************************************************************
* Win32WSDialogs.pp *
* ----------------- *
* *
* *
*****************************************************************************
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
unit Win32WSDialogs;
{$mode objfpc}{$H+}
{$I win32defines.inc}
{.$DEFINE VerboseTaskDialog}
{.$define simulate_vistaf_filedialog_failure}
interface
uses
////////////////////////////////////////////////////
// I M P O R T A N T
////////////////////////////////////////////////////
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
// rtl
Windows, shlobj, ShellApi, ActiveX, SysUtils, Classes, CommDlg,
{$ifdef DebugCommonDialogEvents}
System.UITypes,
{$endif}
// lcl
LCLProc, LCLType, Dialogs, Controls, Graphics, Forms, Masks,
// LazUtils
LazFileUtils, LazUTF8,
// ws
WSDialogs, WSLCLClasses, Win32Extra, Win32Int, InterfaceBase,
Win32Proc;
type
TApplicationState = record
ActiveWindow: HWND;
FocusedWindow: HWND;
DisabledWindows: TList;
end;
TOpenFileDialogRec = record
Dialog: TFileDialog;
AnsiFolderName: string;
AnsiFileNames: string;
UnicodeFolderName: widestring;
UnicodeFileNames: widestring
end;
POpenFileDialogRec = ^TOpenFileDialogRec;
{ TWin32WSCommonDialog }
TWin32WSCommonDialog = class(TWSCommonDialog)
published
class function CreateHandle(const ACommonDialog: TCommonDialog): THandle; override;
class procedure DestroyHandle(const ACommonDialog: TCommonDialog); override;
end;
{ TWin32WSFileDialog }
TWin32WSFileDialog = class(TWSFileDialog)
published
end;
{ TWin32WSOpenDialog }
{$ifdef simulate_vistaf_filedialog_failure}
const
CLSID_FileOpenDialog : TGUID = '{DC1C5A9C-E88A-4dde-A5A1-60F82A200000}';
CLSID_FileSaveDialog : TGUID = '{C0B4E2F3-BA21-4773-8DBA-335EC9000000}';
{$endif simulate_vistaf_filedialog_failure}
type
TWin32WSOpenDialog = class(TWSOpenDialog)
public
class function GetVistaOptions(Options: TOpenOptions; OptionsEx: TOpenOptionsEx; SelectFolder: Boolean): FileOpenDialogOptions;
class procedure SetupVistaFileDialog(ADialog: IFileDialog; const AOpenDialog: TOpenDialog);
class function ProcessVistaDialogResult(ADialog: IFileDialog; const AOpenDialog: TOpenDialog): HResult;
class procedure VistaDialogShowModal(ADialog: IFileDialog; const AOpenDialog: TOpenDialog);
class function GetFileName(ShellItem: IShellItem): String;
class function GetParentWnd: HWND;
published
class function CreateHandle(const ACommonDialog: TCommonDialog): THandle; override;
class procedure DestroyHandle(const ACommonDialog: TCommonDialog); override;
class procedure ShowModal(const ACommonDialog: TCommonDialog); override;
class function QueryWSEventCapabilities(const ACommonDialog: TCommonDialog): TCDWSEventCapabilities; override;
end;
{ TWin32WSSaveDialog }
TWin32WSSaveDialog = class(TWSSaveDialog)
published
class function CreateHandle(const ACommonDialog: TCommonDialog): THandle; override;
class procedure DestroyHandle(const ACommonDialog: TCommonDialog); override;
class procedure ShowModal(const ACommonDialog: TCommonDialog); override;
class function QueryWSEventCapabilities(const ACommonDialog: TCommonDialog): TCDWSEventCapabilities; override;
end;
{ TWin32WSSelectDirectoryDialog }
TWin32WSSelectDirectoryDialog = class(TWSSelectDirectoryDialog)
public
class function CreateOldHandle(const ACommonDialog: TCommonDialog): THandle;
published
class function CreateHandle(const ACommonDialog: TCommonDialog): THandle; override;
class function QueryWSEventCapabilities(const ACommonDialog: TCommonDialog): TCDWSEventCapabilities; override;
end;
{ TWin32WSColorDialog }
TWin32WSColorDialog = class(TWSColorDialog)
public
class function ColorDialogOptionsToFlags(Options: TColorDialogOptions): DWORD;
published
class function CreateHandle(const ACommonDialog: TCommonDialog): THandle; override;
class procedure ShowModal(const ACommonDialog: TCommonDialog); override;
class procedure DestroyHandle(const ACommonDialog: TCommonDialog); override;
class function QueryWSEventCapabilities(const ACommonDialog: TCommonDialog): TCDWSEventCapabilities; override;
end;
{ TWin32WSColorButton }
TWin32WSColorButton = class(TWSColorButton)
published
end;
{ TWin32WSFontDialog }
TWin32WSFontDialog = class(TWSFontDialog)
published
class function CreateHandle(const ACommonDialog: TCommonDialog): THandle; override;
class function QueryWSEventCapabilities(const ACommonDialog: TCommonDialog): TCDWSEventCapabilities; override;
end;
{ TFileDialogEvents }
TFileDialogEvents = class(TInterfacedObject, IFileDialogEvents, IFileDialogControlEvents)
private
FDialog: TOpenDialog;
protected
// IFileDialogEvents
function OnFileOk(pfd: IFileDialog): HResult; stdcall;
function OnFolderChanging({%H-}pfd: IFileDialog; {%H-}psifolder: IShellItem): HResult; stdcall;
function OnFolderChange({%H-}pfd: IFileDialog): HResult; stdcall;
function OnSelectionChange(pfd: IFileDialog): HResult; stdcall;
function OnShareViolation({%H-}pfd: IFileDialog; {%H-}psi: IShellItem; {%H-}pResponse: pFDE_SHAREVIOLATION_RESPONSE): HResult; stdcall;
function OnTypeChange(pfd: IFileDialog): HResult; stdcall;
function OnOverwrite({%H-}pfd: IFileDialog; {%H-}psi: IShellItem; {%H-}pResponse: pFDE_OVERWRITE_RESPONSE): HResult; stdcall;
// IFileDialogControlEvents
function OnItemSelected({%H-}pfdc: IFileDialogCustomize; {%H-}dwIDCtl: DWORD; {%H-}dwIDItem: DWORD): HResult; stdcall;
function OnButtonClicked({%H-}pfdc: IFileDialogCustomize; {%H-}dwIDCtl: DWORD): HResult; stdcall;
function OnCheckButtonToggled({%H-}pfdc: IFileDialogCustomize; {%H-}dwIDCtl: DWORD; {%H-}bChecked: BOOL): HResult; stdcall;
function OnControlActivating({%H-}pfdc: IFileDialogCustomize; {%H-}dwIDCtl: DWORD): HResult; stdcall;
public
constructor Create(ADialog: TOpenDialog);
end;
{ TWin32WSTaskDialog }
TWin32WSTaskDialog = class(TWSTaskDialog)
published
class function Execute(const ADlg: TCustomTaskDialog; AParentWnd: HWND; out ARadioRes: Integer): Integer; override;
end;
function OpenFileDialogCallBack(Wnd: HWND; uMsg: UINT; {%H-}wParam: WPARAM;
lParam: LPARAM): UINT_PTR; stdcall;
function SaveApplicationState: TApplicationState;
procedure RestoreApplicationState(AState: TApplicationState);
function UTF8StringToPWideChar(const s: string) : PWideChar;
function UTF8StringToPAnsiChar(const s: string) : PAnsiChar;
function CanUseVistaDialogs(const AOpenDialog: TOpenDialog): Boolean;
var
cOpenDialogAllFiles: string = 'All files';
implementation
uses
CommCtrl, TaskDlgEmulation, contnrs;
function SaveApplicationState: TApplicationState;
begin
Result.ActiveWindow := Windows.GetActiveWindow;
Result.FocusedWindow := Windows.GetFocus;
Result.DisabledWindows := Screen.DisableForms(nil);
Application.ModalStarted;
end;
procedure RestoreApplicationState(AState: TApplicationState);
begin
Screen.EnableForms(AState.DisabledWindows);
Windows.SetActiveWindow(AState.ActiveWindow);
Windows.SetFocus(AState.FocusedWindow);
Application.ModalFinished;
end;
// The size of the OPENFILENAME record depends on the windows version
// In the initialization section the correct size is determined.
var
OpenFileNameSize: integer = 0;
// Returns a new PWideChar containing the string UTF8 string s as widechars
function UTF8StringToPWideChar(const s: string) : PWideChar;
begin
// a string of widechars will need at most twice the amount of bytes
// as the corresponding UTF8 string
Result := GetMem(length(s)*2+2);
Utf8ToUnicode(Result,length(s)+1,pchar(s),length(s)+1);
end;
// Returns a new PChar containing the string UTF8 string s as ansichars
function UTF8StringToPAnsiChar(const s: string) : PAnsiChar;
var
AnsiChars: string;
begin
AnsiChars:= Utf8ToAnsi(s);
Result := GetMem(length(AnsiChars)+1);
Move(PChar(AnsiChars)^, Result^, length(AnsiChars)+1);
end;
procedure UpdateFileProperties(OpenFile: LPOPENFILENAME);
var
DialogRec: POpenFileDialogRec;
AOpenDialog: TOpenDialog;
procedure SetFilesPropertyCustomFiles(AFiles:TStrings);
procedure AddFile(FolderName, FileName: String); inline;
begin
if ExtractFilePath(FileName) = '' then
AFiles.Add(FolderName + FileName)
else
AFiles.Add(FileName);
end;
var
i, Start, len: integer;
FolderName: string;
FileNames: string;
begin
FolderName := UTF16ToUTF8(DialogRec^.UnicodeFolderName);
FileNames := UTF16ToUTF8(DialogRec^.UnicodeFileNames);
if FolderName='' then
begin
// On Windows 7, the SendMessageW(GetParent(Wnd), CDM_GETFOLDERPATH, 0, LPARAM(nil))
// at UpdateStorage might fail (see #16797)
// However, the valid directory is returned in OpenFile^.lpstrFile
//
// What was the reason not to use OpenFile^.lpstrFile, since it's list
// of the selected files, without need of writting any callbacks!
FolderName:=UTF16ToUTF8(PWidechar(OpenFile^.lpstrFile));
// Check for DirectoryExistsUTF8(FolderName) is required, because Win 7
// sometimes returns a single file name in OpenFile^.lpstrFile, while
// OFN_ALLOWMULTISELECT is set
// to reproduce.
// 1. Allow mulitple files in OpenDialog options. Run the project.
// 2. OpenDialog.Execute -> Library -> Documens. Select a single file!
if (OpenFile^.Flags and OFN_ALLOWMULTISELECT=0) or not DirectoryExistsUTF8(FolderName) then
FolderName:=ExtractFileDir(FolderName);
end;
FolderName := AppendPathDelim(FolderName);
len := Length(FileNames);
if (len > 0) and (FileNames[1] = '"') then
begin
Start := 1; // first quote is on pos 1
while (start <= len) and (FileNames[Start] <> #0) do
begin
i := Start + 1;
while FileNames[i] <> '"' do
inc(i);
AddFile(FolderName, Copy(FileNames, Start + 1, I - Start - 1));
Start := i + 1;
while (Start <= len) and (FileNames[Start] <> #0) and (FileNames[Start] <> '"') do
inc(Start);
end;
end
else
AddFile(FolderName, FileNames);
end;
procedure SetFilesPropertyForOldStyle(AFiles:TStrings);
var
SelectedStr: string;
FolderName: string;
I,Start: integer;
begin
SelectedStr:=UTF16ToUTF8(widestring(PWideChar(OpenFile^.lpStrFile)));
if not (ofAllowMultiSelect in AOpenDialog.Options) then
AFiles.Add(SelectedStr)
else begin
Start:=Pos(' ',SelectedStr);
FolderName := copy(SelectedStr,1,start-1);
SelectedStr:=SelectedStr+' ';
inc(start);
for I:= Start to Length(SelectedStr) do
if SelectedStr[I] = ' ' then
begin
AFiles.Add(ExpandFileNameUTF8(FolderName+Copy(SelectedStr,Start,I - Start)));
Start:=Succ(I);
end;
end;
end;
begin
DialogRec := POpenFileDialogRec(OpenFile^.lCustData);
AOpenDialog := TOpenDialog(DialogRec^.Dialog);
AOpenDialog.Files.Clear;
AOpenDialog.FilterIndex := OpenFile^.nFilterIndex;
if (ofOldStyleDialog in AOpenDialog.Options) then
SetFilesPropertyForOldStyle(AOpenDialog.Files)
else
SetFilesPropertyCustomFiles(AOpenDialog.Files);
AOpenDialog.FileName := AOpenDialog.Files[0];
end;
{------------------------------------------------------------------------------
Method: GetOwnerHandle
Params: ADialog - dialog to get 'guiding parent' window handle for
Returns: A window handle
Returns window handle to be used as 'owner handle', ie. so that the user must
finish the dialog before continuing
------------------------------------------------------------------------------}
function GetOwnerHandle(ADialog : TCommonDialog): HWND;
begin
if (Screen.ActiveForm<>nil) and Screen.ActiveForm.HandleAllocated then
Result := Screen.ActiveForm.Handle
else
Result := Application.MainFormHandle;
end;
procedure SetDialogResult(const ACommonDialog: TCommonDialog; Ret: WINBOOL);
begin
if Ret then
ACommonDialog.UserChoice := mrOK
else
ACommonDialog.UserChoice := mrCancel;
end;
{ TWin32WSColorDialog }
Function CCHookProc(H: THandle; msg: Cardinal; W: WParam; L: LParam): UintPtr; StdCall;
var
ws: WideString;
begin
if (H <> 0) and (Msg = WM_InitDialog) then
begin
ws := WideString(TColorDialog(PChooseColor(L)^.lCustData).Title);
SetWindowTextW(H, PWideChar(ws));
end;
Result := 0;
end;
class function TWin32WSColorDialog.ColorDialogOptionsToFlags(Options: TColorDialogOptions): DWORD;
{$if fpc_fullversion < 30301}
const
CC_ANYCOLOR = $00000100;
{$endif fpc_fullversion < 30301}
begin
Result := 0;
if cdFullOpen in Options then Result := Result or CC_FULLOPEN;
if cdPreventFullOpen in Options then Result := Result or CC_PREVENTFULLOPEN;
if cdShowHelp in Options then Result := Result or CC_SHOWHELP;
if cdSolidColor in Options then Result := Result or CC_SOLIDCOLOR;
if cdAnyColor in Options then Result := Result or CC_ANYCOLOR;
end;
class function TWin32WSColorDialog.CreateHandle(const ACommonDialog: TCommonDialog): THandle;
var
CC: PChooseColor;
ColorDialog: TColorDialog absolute ACommonDialog;
procedure FillCustomColors;
var
i, AIndex: integer;
AColor: TColor;
begin
for i := 0 to ColorDialog.CustomColors.Count - 1 do
if ExtractColorIndexAndColor(ColorDialog.CustomColors, i, AIndex, AColor) then
begin
if AIndex < 16 then
CC^.lpCustColors[AIndex] := AColor;
end;
end;
begin
CC := AllocMem(SizeOf(TChooseColor));
with CC^ Do
begin
LStructSize := sizeof(TChooseColor);
HWndOwner := GetOwnerHandle(ACommonDialog);
RGBResult := ColorToRGB(ColorDialog.Color);
LPCustColors := AllocMem(16 * SizeOf(DWord));
FillCustomColors;
lCustData := LParam(ACommonDialog);
lpfnHook := @CCHookProc;
Flags := {CC_FULLOPEN or }CC_RGBINIT or CC_ENABLEHOOK;
Flags := Flags or ColorDialogOptionsToFlags(ColorDialog.Options);
end;
Result := THandle(CC);
end;
class procedure TWin32WSColorDialog.ShowModal(const ACommonDialog: TCommonDialog);
var
CC: PChooseColor;
UserResult: WINBOOL;
State: TApplicationState;
i: Integer;
begin
if ACommonDialog.Handle <> 0 then
begin
State := SaveApplicationState;
try
CC := PChooseColor(ACommonDialog.Handle);
UserResult := ChooseColor(CC);
SetDialogResult(ACommonDialog, UserResult);
if UserResult then
begin
TColorDialog(ACommonDialog).Color := CC^.RGBResult;
for i := 0 to 15 do
if i < TColorDialog(ACommonDialog).CustomColors.Count then
TColorDialog(ACommonDialog).CustomColors[i] := Format('Color%s=%x', [Chr(Ord('A')+i), CC^.lpCustColors[i]])
else
TColorDialog(ACommonDialog).CustomColors.Add (Format('Color%s=%x', [Chr(Ord('A')+i), CC^.lpCustColors[i]]));
end;
finally
RestoreApplicationState(State);
end;
end;
end;
class procedure TWin32WSColorDialog.DestroyHandle(
const ACommonDialog: TCommonDialog);
var
CC: PChooseColor;
begin
if ACommonDialog.Handle <> 0 then
begin
CC := PChooseColor(ACommonDialog.Handle);
FreeMem(CC^.lpCustColors);
FreeMem(CC);
end;
end;
class function TWin32WSColorDialog.QueryWSEventCapabilities(
const ACommonDialog: TCommonDialog): TCDWSEventCapabilities;
begin
Result := [cdecWSNoCanCloseSupport];
end;
procedure UpdateStorage(Wnd: HWND; OpenFile: LPOPENFILENAME);
var
FilesSize: SizeInt;
FolderSize: SizeInt;
DialogRec: POpenFileDialogRec;
begin
DialogRec := POpenFileDialogRec(OpenFile^.lCustData);
FolderSize := SendMessageW(GetParent(Wnd), CDM_GETFOLDERPATH, 0, LPARAM(nil));
FilesSize := SendMessageW(GetParent(Wnd), CDM_GETSPEC, 0, LPARAM(nil));
SetLength(DialogRec^.UnicodeFolderName, FolderSize - 1);
SendMessageW(GetParent(Wnd), CDM_GETFOLDERPATH, FolderSize,
LPARAM(PWideChar(DialogRec^.UnicodeFolderName)));
SetLength(DialogRec^.UnicodeFileNames, FilesSize - 1);
SendMessageW(GetParent(Wnd), CDM_GETSPEC, FilesSize,
LPARAM(PWideChar(DialogRec^.UnicodeFileNames)));
end;
{Common code for OpenDialog and SaveDialog}
{The API of the multiselect open file dialog is a bit problematic.
Before calling the OpenFile function you must create a buffer (lpStrFile) to
hold the selected files.
With a multiselect dialog there is no way to create a buffer with correct size:
* either it is too small (for example 1 KB), if a lot a files are selected
* or it wastes a lot of memory (for example 1 MB), and even than you have no
guarantee, that is big enough.
The OpenFile API call returns false, if an error has occurred or the user has
pressed cancel. If there was an error CommDlgExtendedError returns
FNERR_BUFFERTOOSMALL. But enlarging the buffer at that time is not useful
anymore, unless you show the dialog again with a bigger buffer (Sorry, the
buffer was too small, please select the files again). This is not acceptable.
It is possible to hook the filedialog, so you get messages, when the selection
changes. A naive aproach would be to see, if the buffer would be big enough for
the selected files and create or enlarge the buffer (as described in KB131462).
Unfortunately, this only works with win9x and the unicode versions of later
windows versions.
Therefore in the hook function, if the size of the initial buffer (lpStrFile)
is not large enough, the selected files are copied into a string. A pointer to
this string is kept in the lCustData field of the the OpenFileName struct.
When dialog is closed with a FNERR_BUFFERTOOSMALL error, this string is used to
get the selected files. If this error did not occur, the normal way of
retrieving the files is used.
}
function OpenFileDialogCallBack(Wnd: HWND; uMsg: UINT; wParam: WPARAM;
lParam: LPARAM): UINT_PTR; stdcall;
var
OpenFileNotify: LPOFNOTIFY;
OpenFileName: Windows.POPENFILENAME;
DlgRec: POpenFileDialogRec;
CanClose: Boolean;
{
procedure Reposition(ADialogWnd: Handle);
var
Left, Top: Integer;
ABounds, DialogRect: TRect;
begin
// Btw, setting width and height of dialog doesnot reposition child controls :(
// So no way to set another height and width at least here
if (GetParent(ADialogWnd) = Win32WidgetSet.AppHandle) then
begin
if Screen.ActiveCustomForm <> nil then
ABounds := Screen.ActiveCustomForm.Monitor.BoundsRect
else
if Application.MainForm <> nil then
ABounds := Application.MainForm.Monitor.BoundsRect
else
ABounds := Screen.PrimaryMonitor.BoundsRect;
end
else
ABounds := Screen.MonitorFromWindow(GetParent(ADialogWnd)).BoundsRect;
GetWindowRect(ADialogWnd, @DialogRect);
Left := (ABounds.Right - DialogRect.Right + DialogRect.Left) div 2;
Top := (ABounds.Bottom - DialogRect.Bottom + DialogRect.Top) div 2;
SetWindowPos(ADialogWnd, HWND_TOP, Left, Top, 0, 0, SWP_NOSIZE);
end;
}
procedure ExtractDataFromNotify;
begin
OpenFileName := OpenFileNotify^.lpOFN;
DlgRec := POpenFileDialogRec(OpenFileName^.lCustData);
UpdateStorage(Wnd, OpenFileName);
UpdateFileProperties(OpenFileName);
end;
begin
Result := 0;
if uMsg = WM_INITDIALOG then
begin
// Windows asks us to initialize dialog. At this moment controls are not
// arranged and this is that moment when we should set bounds of our dialog
//Reposition(GetParent(Wnd)); this causes active form to move out of position with old dialogs JP
end
else
if uMsg = WM_NOTIFY then
begin
OpenFileNotify := LPOFNOTIFY(lParam);
if OpenFileNotify = nil then
Exit;
case OpenFileNotify^.hdr.code of
CDN_INITDONE:
begin
ExtractDataFromNotify;
{$ifdef DebugCommonDialogEvents}
debugln(['OpenFileDialogCallBack calling DoShow']);
{$endif}
TOpenDialog(DlgRec^.Dialog).DoShow;
end;
CDN_SELCHANGE:
begin
ExtractDataFromNotify;
TOpenDialog(DlgRec^.Dialog).DoSelectionChange;
end;
CDN_FOLDERCHANGE:
begin
ExtractDataFromNotify;
TOpenDialog(DlgRec^.Dialog).DoFolderChange;
end;
CDN_FILEOK:
begin
ExtractDataFromNotify;
CanClose := True;
TOpenDialog(DlgRec^.Dialog).UserChoice := mrOK;
{$ifdef DebugCommonDialogEvents}
debugln(['OpenFileDialogCallBack calling DoCanClose']);
{$endif}
TOpenDialog(DlgRec^.Dialog).DoCanClose(CanClose);
{$ifdef DebugCommonDialogEvents}
debugln(['OpenFileDialogCallBack CanClose=',CanClose]);
{$endif}
if not CanClose then
begin
//the dialog window will not process the click on OK button
//as a result the dialog will not close
SetWindowLongPtrW(Wnd, DWL_MSGRESULT, 1);
Result := 1;
end;
end;
CDN_TYPECHANGE:
begin
ExtractDataFromNotify;
DlgRec^.Dialog.IntfFileTypeChanged(OpenFileNotify^.lpOFN^.nFilterIndex);
end;
end;
end;
end;
function GetDefaultExt(AOpenDialog: TOpenDialog): String;
begin
Result := AOpenDialog.DefaultExt;
if (Result<>'') and (Result[1]='.') then
System.Delete(Result, 1, 1);
end;
function CreateFileDialogHandle(AOpenDialog: TOpenDialog): THandle;
function GetFlagsFromOptions(Options: TOpenOptions): DWord;
begin
Result := OFN_ENABLEHOOK;
if ofAllowMultiSelect in Options then Result := Result or OFN_ALLOWMULTISELECT;
if ofCreatePrompt in Options then Result := Result or OFN_CREATEPROMPT;
if not (ofOldStyleDialog in Options) then Result := Result or OFN_EXPLORER;
if ofExtensionDifferent in Options then Result := Result or OFN_EXTENSIONDIFFERENT;
if ofFileMustExist in Options then Result := Result or OFN_FILEMUSTEXIST;
if ofHideReadOnly in Options then Result := Result or OFN_HIDEREADONLY;
if ofNoChangeDir in Options then Result := Result or OFN_NOCHANGEDIR;
if ofNoDereferenceLinks in Options then Result := Result or OFN_NODEREFERENCELINKS;
if ofEnableSizing in Options then Result := Result or OFN_ENABLESIZING;
if ofNoLongNames in Options then Result := Result or OFN_NOLONGNAMES;
if ofNoNetworkButton in Options then Result := Result or OFN_NONETWORKBUTTON;
if ofNoReadOnlyReturn in Options then Result := Result or OFN_NOREADONLYRETURN;
if ofNoTestFileCreate in Options then Result := Result or OFN_NOTESTFILECREATE;
if ofNoValidate in Options then Result := Result or OFN_NOVALIDATE;
if ofOverwritePrompt in Options then Result := Result or OFN_OVERWRITEPROMPT;
if ofPathMustExist in Options then Result := Result or OFN_PATHMUSTEXIST;
if ofReadOnly in Options then Result := Result or OFN_READONLY;
if ofShareAware in Options then Result := Result or OFN_SHAREAWARE;
if ofShowHelp in Options then Result := Result or OFN_SHOWHELP;
if ofDontAddToRecent in Options then Result := Result or OFN_DONTADDTORECENT;
if ofForceShowHidden in Options then Result := Result or OFN_FORCESHOWHIDDEN;
end;
procedure ReplacePipe(var AFilter:string);
var
i: integer;
begin
for i := 1 to Length(AFilter) do
if AFilter[i] = '|' then AFilter[i] := #0;
AFilter := AFilter + #0;
end;
const
FileNameBufferLen = 1000;
var
DialogRec: POpenFileDialogRec;
OpenFile: LPOPENFILENAME;
Filter, FileName, InitialDir, DefaultExt: String;
FileNameWide: WideString;
FileNameWideBuffer: PWideChar;
FileNameBufferSize: Integer;
begin
{$ifdef DebugCommonDialogEvents}
debugln(['CreateFileDialogHandle A']);
{$endif}
FileName := AOpenDialog.FileName;
InitialDir := AOpenDialog.InitialDir;
if (FileName <> '') and (FileName[length(FileName)] = PathDelim) then
begin
// if the filename contains a directory, set the initial directory
// and clear the filename
InitialDir := Copy(FileName, 1, Length(FileName) - 1);
FileName := '';
end;
DefaultExt := GetDefaultExt(AOpenDialog);
FileNameWideBuffer := AllocMem(FileNameBufferLen * 2 + 2);
FileNameWide := UTF8ToUTF16(FileName);
if Length(FileNameWide) > FileNameBufferLen then
FileNameBufferSize := FileNameBufferLen
else
FileNameBufferSize := Length(FileNameWide);
Move(PWideChar(FileNameWide)^, FileNameWideBuffer^, FileNameBufferSize * 2);
if AOpenDialog.Filter <> '' then
begin
Filter := AOpenDialog.Filter;
ReplacePipe(Filter);
end
else
Filter := cOpenDialogAllFiles+' (*.*)'+#0+'*.*'+#0; // Default -> avoid empty combobox
OpenFile := AllocMem(SizeOf(OpenFileName));
with OpenFile^ do
begin
lStructSize := OpenFileNameSize;
hWndOwner := GetOwnerHandle(AOpenDialog);
hInstance := System.hInstance;
nFilterIndex := AOpenDialog.FilterIndex;
lpStrFile := PChar(FileNameWideBuffer);
lpstrFilter := PChar(UTF8StringToPWideChar(Filter));
lpstrTitle := PChar(UTF8StringToPWideChar(AOpenDialog.Title));
lpstrInitialDir := PChar(UTF8StringToPWideChar(InitialDir));
lpstrDefExt := PChar(UTF8StringToPWideChar(DefaultExt));
nMaxFile := FileNameBufferLen + 1; // Size in TCHARs
lpfnHook := Windows.LPOFNHOOKPROC(@OpenFileDialogCallBack);
Flags := GetFlagsFromOptions(AOpenDialog.Options);
if (ofExNoPlacesBar in AOpenDialog.OptionsEx) then
FlagsEx := OFN_EX_NOPLACESBAR;
New(DialogRec);
// new initializes the filename fields, because ansistring and widestring
// are automated types.
DialogRec^.Dialog := AOpenDialog;
lCustData := LParam(DialogRec);
end;
Result := THandle(OpenFile);
{$ifdef DebugCommonDialogEvents}
debugln(['CreateFileDialogHandle End']);
{$endif}
end;
procedure DestroyFileDialogHandle(AHandle: THandle);
var
OPENFILE: LPOPENFILENAME;
begin
OPENFILE := LPOPENFILENAME(AHandle);
if OPENFILE^.lCustData <> 0 then
Dispose(POpenFileDialogRec(OPENFILE^.lCustData));
FreeMem(OpenFile^.lpStrFilter);
FreeMem(OpenFile^.lpstrInitialDir);
FreeMem(OpenFile^.lpStrFile);
FreeMem(OpenFile^.lpStrTitle);
FreeMem(OpenFile^.lpTemplateName);
FreeMem(OpenFile^.lpstrDefExt);
FreeMem(OpenFile);
end;
procedure ProcessFileDialogResult(AOpenDialog: TOpenDialog; UserResult: WordBool);
var
OpenFile: LPOPENFILENAME;
begin
OpenFile := LPOPENFILENAME(AOpenDialog.Handle);
if not UserResult and (CommDlgExtendedError = FNERR_BUFFERTOOSMALL) then
UserResult := True;
SetDialogResult(AOpenDialog, UserResult);
if UserResult then
begin
UpdateFileProperties(OpenFile);
AOpenDialog.IntfSetOption(ofExtensionDifferent, OpenFile^.Flags and OFN_EXTENSIONDIFFERENT <> 0);
AOpenDialog.IntfSetOption(ofReadOnly, OpenFile^.Flags and OFN_READONLY <> 0);
end
else
begin
AOpenDialog.Files.Clear;
AOpenDialog.FileName := '';
end;
end;
{ TWin32WSOpenDialog }
var
XPStyleFallBackList: TFPObjectList = nil;
procedure MaybeInitXPStyleFallBackList;
begin
if not Assigned(XPStyleFallBackList) then
XPStyleFallBackList := TFPObjectList.Create(False); //don't free objects
end;
procedure FreeXPStyleFallBackList;
begin
if Assigned(XPStyleFallBackList) then
FreeAndNil(XPStyleFallBackList);
end;
function IsXPStyleFallBack(const AOpenDialog: TOpenDialog): Boolean;
var
Idx: Integer;
begin
if not Assigned(XPStyleFallBackList) or not (ofUseXPStyleAsFallBack in AOpenDialog.OptionsEx) then
Exit(False);
Idx := XPStyleFallBackList.IndexOf(AOpenDialog);
Result := (Idx <> -1);
end;
function IsXPStyleFallBack(const AOpenDialog: TOpenDialog; out Idx: Integer): Boolean;
begin
if not Assigned(XPStyleFallBackList) or not (ofUseXPStyleAsFallBack in AOpenDialog.OptionsEx) then
Exit(False);
Idx := XPStyleFallBackList.IndexOf(AOpenDialog);
Result := (Idx <> -1);
end;
function CanUseVistaDialogs(const AOpenDialog: TOpenDialog): Boolean;
begin
{$IFnDEF DisableVistaDialogs}
Result := (WindowsVersion >= wvVista) and not (ofOldStyleDialog in AOpenDialog.Options);
{$ELSE}
Result := False;
{$ENDIF}
end;
class procedure TWin32WSOpenDialog.SetupVistaFileDialog(ADialog: IFileDialog; const AOpenDialog: TOpenDialog);
var
I: Integer;
FileName, InitialDir: String;
DefaultFolderItem: IShellItem;
ParsedFilter: TParseStringList;
FileTypesArray: PCOMDLG_FILTERSPEC;
begin
FileName := AOpenDialog.FileName;
InitialDir := AOpenDialog.InitialDir;
if (FileName <> '') and (FileName[length(FileName)] = PathDelim) then
begin
// if the filename contains a directory, set the initial directory
// and clear the filename
InitialDir := Copy(FileName, 1, Length(FileName) - 1);
FileName := '';
end;
ADialog.SetTitle(PWideChar(UTF8ToUTF16(AOpenDialog.Title)));
ADialog.SetFileName(PWideChar(UTF8ToUTF16(FileName)));
ADialog.SetDefaultExtension(PWideChar(UTF8ToUTF16(GetDefaultExt(AOpenDialog))));
if InitialDir <> '' then
begin
if Succeeded(SHCreateItemFromParsingName(PWideChar(UTF8ToUTF16(InitialDir)), nil, IShellItem, DefaultFolderItem)) then
ADialog.SetFolder(DefaultFolderItem);
end;
ParsedFilter := TParseStringList.Create(AOpenDialog.Filter, '|');
if ParsedFilter.Count = 0 then
begin
ParsedFilter.Add(cOpenDialogAllFiles+' (*.*)');
ParsedFilter.Add('*.*');
end;
try
FileTypesArray := AllocMem((ParsedFilter.Count div 2) * SizeOf(TCOMDLG_FILTERSPEC));
for I := 0 to ParsedFilter.Count div 2 - 1 do
begin
FileTypesArray[I].pszName := UTF8StringToPWideChar(ParsedFilter[I * 2]);
FileTypesArray[I].pszSpec := UTF8StringToPWideChar(ParsedFilter[I * 2 + 1]);
end;
ADialog.SetFileTypes(ParsedFilter.Count div 2, FileTypesArray);
ADialog.SetFileTypeIndex(AOpenDialog.FilterIndex);
for I := 0 to ParsedFilter.Count div 2 - 1 do
begin
FreeMem(FileTypesArray[I].pszName);
FreeMem(FileTypesArray[I].pszSpec);
end;
FreeMem(FileTypesArray);
finally
ParsedFilter.Free;
end;
ADialog.SetOptions(GetVistaOptions(AOpenDialog.Options, AOpenDialog.OptionsEx, AOpenDialog is TSelectDirectoryDialog));
end;
class function TWin32WSOpenDialog.GetFileName(ShellItem: IShellItem): String;
var
FilePath: LPWStr;
begin
if Succeeded(ShellItem.GetDisplayName(SIGDN(SIGDN_FILESYSPATH), LPWStr(@FilePath))) then
begin
Result := UTF16ToUTF8(FilePath);
CoTaskMemFree(FilePath);
end
else
Result := '';
end;
class function TWin32WSOpenDialog.GetVistaOptions(Options: TOpenOptions;
OptionsEx: TOpenOptionsEx; SelectFolder: Boolean): FileOpenDialogOptions;
{$if fpc_fullversion < 30203}
const
FOS_OKBUTTONNEEDSINTERACTION = $200000; //not yet in ShlObj
{$endif fpc_fullversion < 30203}
begin
Result := 0;
if ofAllowMultiSelect in Options then Result := Result or FOS_ALLOWMULTISELECT;
if ofCreatePrompt in Options then Result := Result or FOS_CREATEPROMPT;
//if ofExtensionDifferent in Options then Result := Result or FOS_STRICTFILETYPES; //that's just wrong
if ofFileMustExist in Options then Result := Result or FOS_FILEMUSTEXIST;
if ofNoChangeDir in Options then Result := Result or FOS_NOCHANGEDIR;
if ofNoDereferenceLinks in Options then Result := Result or FOS_NODEREFERENCELINKS;
if ofNoReadOnlyReturn in Options then Result := Result or FOS_NOREADONLYRETURN;
if ofNoTestFileCreate in Options then Result := Result or FOS_NOTESTFILECREATE;
if ofNoValidate in Options then Result := Result or FOS_NOVALIDATE;
if ofOverwritePrompt in Options then Result := Result or FOS_OVERWRITEPROMPT;
if ofPathMustExist in Options then Result := Result or FOS_PATHMUSTEXIST;
if ofShareAware in Options then Result := Result or FOS_SHAREAWARE;
if ofDontAddToRecent in Options then Result := Result or FOS_DONTADDTORECENT;
if SelectFolder or (ofPickFolders in OptionsEx) then Result := Result or FOS_PICKFOLDERS;
if ofForceShowHidden in Options then Result := Result or FOS_FORCESHOWHIDDEN;
{ unavailable options:
ofHideReadOnly
ofEnableSizing
ofNoLongNames
ofNoNetworkButton
ofReadOnly
ofShowHelp
}
{ non-used flags:
FOS_HIDEMRUPLACES, FOS_DEFAULTNOMINIMODE: both of them are unsupported as of Win7
FOS_SUPPORTSTREAMABLEITEMS
}
if ofHidePinnedPlaces in OptionsEx then Result := Result or FOS_HIDEPINNEDPLACES;
if ofForcePreviewPaneOn in OptionsEx then Result := Result or FOS_FORCEPREVIEWPANEON;
if ofStrictFileTypes in OptionsEx then Result := Result or FOS_STRICTFILETYPES;
if ofOkButtonNeedsInteraction in OptionsEx then Result := Result or FOS_OKBUTTONNEEDSINTERACTION;
if ofForceFileSystem in OptionsEx then Result := Result or FOS_FORCEFILESYSTEM;
if ofAllNonStorageItems in OptionsEx then Result := Result or FOS_ALLNONSTORAGEITEMS;
end;
class function TWin32WSOpenDialog.ProcessVistaDialogResult(ADialog: IFileDialog; const AOpenDialog: TOpenDialog): HResult;
var
ShellItems: IShellItemArray = nil;
ShellItem: IShellItem = nil;
I: DWORD;
Count: DWORD = 0;
begin
// TODO: ofExtensionDifferent, ofReadOnly
if not Supports(ADialog, IFileOpenDialog) then
Result := E_FAIL
else
Result := (ADialog as IFileOpenDialog).GetResults(ShellItems);
if Succeeded(Result) and Succeeded(ShellItems.GetCount(Count)) then
begin
AOpenDialog.Files.Clear;
I := 0;
while I < Count do
begin
if Succeeded(ShellItems.GetItemAt(I, ShellItem)) then
AOpenDialog.Files.Add(GetFileName(ShellItem));
inc(I);
end;
if AOpenDialog.Files.Count > 0 then
AOpenDialog.FileName := AOpenDialog.Files[0]
else
AOpenDialog.FileName := '';
end
else
begin
Result := ADialog.GetResult(@ShellItem);
if Succeeded(Result) then
begin
AOpenDialog.Files.Clear;
AOpenDialog.FileName := GetFileName(ShellItem);
AOpenDialog.Files.Add(AOpenDialog.FileName);
end
else
begin
AOpenDialog.Files.Clear;
AOpenDialog.FileName := '';
end;
end;
end;
class procedure TWin32WSOpenDialog.VistaDialogShowModal(ADialog: IFileDialog; const AOpenDialog: TOpenDialog);
var
FileDialogEvents: IFileDialogEvents;
Cookie: DWord;
//CanClose: Boolean;
begin
{$ifdef DebugCommonDialogEvents}
debugln('TWin32WSOpenDialog.VistaDialogShowModal A');
{$endif}
FileDialogEvents := TFileDialogEvents.Create(AOpenDialog);
ADialog.Advise(FileDialogEvents, @Cookie);
try
{$ifdef DebugCommonDialogEvents}
debugln('TWin32WSOpenDialog.VistaDialogShowModal calling DoShow');
{$endif}
AOpenDialog.DoShow;
ADialog.Show(GetParentWnd);
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSOpenDialog.VistaDialogShowModal: AOpenDialog.UserChoice = ',ModalResultStr[AOpenDialog.UserChoice]]);
{$endif}
//DoOnClose is called from TFileDialogEvents.OnFileOk if user pressed OK
//Do NOT call DoCanClose if user cancels the dialog
//see http://docwiki.embarcadero.com/Libraries/Berlin/en/Vcl.Dialogs.TOpenDialog_Events
//so no need to call it here anymore
if (AOpenDialog.UserChoice <> mrOk) then
begin
AOpenDialog.UserChoice := mrCancel;
end;
finally
ADialog.unadvise(Cookie);
FileDialogEvents := nil;
end;
{$ifdef DebugCommonDialogEvents}
debugln('TWin32WSOpenDialog.VistaDialogShowModal End');
{$endif}
end;
class function TWin32WSOpenDialog.GetParentWnd: HWND;
begin
if Assigned(Screen.ActiveCustomForm) then
Result := Screen.ActiveCustomForm.Handle
else
if Assigned(Application.MainForm) then
Result := Application.MainFormHandle
else
Result := WidgetSet.AppHandle;
end;
class function TWin32WSOpenDialog.CreateHandle(const ACommonDialog: TCommonDialog): THandle;
var
Dialog: IFileDialog; //IFileOpenDialog;
HRes: HRESULT;
DlgType: TIID;
CLS_ID: TGUID;
AOpenDialog: TOpenDialog absolute ACommonDialog;
begin
if CanUseVistaDialogs(AOpenDialog) then
begin
if (ACommonDialog is TSaveDialog) then
begin
CLS_ID := CLSID_FileSaveDialog;
DlgType := IFileSaveDialog;
end
else
begin
CLS_ID := CLSID_FileOpenDialog;
DlgType := IFileOpenDialog;
end;
HRes := CoCreateInstance(CLS_ID, nil, CLSCTX_INPROC_SERVER, DlgType, Dialog);
if Succeeded(HRes) and Assigned(Dialog) then
begin
Dialog._AddRef;
SetupVistaFileDialog(Dialog, AOpenDialog);
Result := THandle(Dialog);
end
else
begin
if (ofUseXPStyleAsFallback in AOpenDialog.OptionsEx) then
begin
MaybeInitXPStyleFallBackList;
XPStyleFallbackList.Add(ACommonDialog);
//debugln(['TWin32WSOpenDialog.CreateHandle: Added ',DbgSName(AOpenDialog),' to XPStyleFallbackList']);
Result := CreateFileDialogHandle(AOpenDialog);
end
else
Result := INVALID_HANDLE_VALUE;
end;
end//CanUseVistaDialogs
else
Result := CreateFileDialogHandle(AOpenDialog);
end;
class procedure TWin32WSOpenDialog.DestroyHandle(const ACommonDialog: TCommonDialog);
var
Dialog: IFileDialog;
Idx: Integer;
begin
if (ACommonDialog.Handle <> 0) and (ACommonDialog.Handle <> INVALID_HANDLE_VALUE) then
begin
if CanUseVistaDialogs(TOpenDialog(ACommonDialog)) and not IsXPStyleFallBack(TOpenDialog(ACommonDialog), Idx) then
begin
Dialog := IFileDialog(ACommonDialog.Handle);
Dialog._Release;
Dialog := nil;
end
else
begin
if (Idx <> -1) then
begin
//debugln(['TWin32WSOpenDialog.CreateHandle: Removing ',DbgSName(ACommonDialog),' from XPStyleFallbackList']);
XPStyleFallBackList.Delete(Idx);
end;
DestroyFileDialogHandle(ACommonDialog.Handle)
end;
end;
end;
class procedure TWin32WSOpenDialog.ShowModal(const ACommonDialog: TCommonDialog);
var
State: TApplicationState;
lOldWorkingDir, lInitialDir: string;
Dialog: IFileOpenDialog;
begin
if ACommonDialog.HandleAllocated and (ACommonDialog.Handle <> INVALID_HANDLE_VALUE) then
begin
State := SaveApplicationState;
lOldWorkingDir := GetCurrentDirUTF8;
try
lInitialDir := TOpenDialog(ACommonDialog).InitialDir;
if lInitialDir <> '' then
SetCurrentDirUTF8(lInitialDir);
if CanUseVistaDialogs(TOpenDialog(ACommonDialog)) and not IsXPStyleFallBack(TOpenDialog(ACommonDialog)) then
begin
Dialog := IFileOpenDialog(ACommonDialog.Handle);
VistaDialogShowModal(Dialog, TOpenDialog(ACommonDialog));
end
else
begin
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSOpenDialog.ShowModal before ProcessFileDialogResults']);
{$endif}
ProcessFileDialogResult(TOpenDialog(ACommonDialog),
GetOpenFileNameW(LPOPENFILENAME(ACommonDialog.Handle)));
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSOpenDialog.ShowModal after ProcessFileDialogResults, UserChoice=',ModalResultStr[TOpenDialog(ACommonDialog).UserChoice]]);
{$endif}
end;
finally
SetCurrentDirUTF8(lOldWorkingDir);
RestoreApplicationState(State);
end;
end;
end;
class function TWin32WSOpenDialog.QueryWSEventCapabilities(
const ACommonDialog: TCommonDialog): TCDWSEventCapabilities;
begin
Result := [cdecWSPerformsDoShow,cdecWSPerformsDoCanClose];
end;
{ TWin32WSSaveDialog }
class function TWin32WSSaveDialog.CreateHandle(const ACommonDialog: TCommonDialog): THandle;
//var
// Dialog: IFileSaveDialog;
begin
Result := TWin32WSOpenDialog.CreateHandle(ACommonDialog);
//if CanUseVistaDialogs(TOpenDialog(ACommonDialog)) then
//begin
// if Succeeded(CoCreateInstance(CLSID_FileSaveDialog, nil, CLSCTX_INPROC_SERVER, IFileSaveDialog, Dialog))
// and Assigned(Dialog) then
// begin
// Dialog._AddRef;
// TWin32WSOpenDialog.SetupVistaFileDialog(Dialog, TOpenDialog(ACommonDialog));
// Result := THandle(Dialog);
// end
// else
// Result := INVALID_HANDLE_VALUE;
//end
//else
// Result := CreateFileDialogHandle(TOpenDialog(ACommonDialog));
end;
class procedure TWin32WSSaveDialog.DestroyHandle(const ACommonDialog: TCommonDialog);
//var
// Dialog: IFileDialog;
begin
TWin32WSOpenDialog.DestroyHandle(ACommonDialog);
//if (ACommonDialog.Handle <> 0) and (ACommonDialog.Handle <> INVALID_HANDLE_VALUE) then
// if CanUseVistaDialogs(TOpenDialog(ACommonDialog)) then
// begin
// Dialog := IFileDialog(ACommonDialog.Handle);
// Dialog._Release;
// Dialog := nil;
// end
// else
// DestroyFileDialogHandle(ACommonDialog.Handle)
end;
class procedure TWin32WSSaveDialog.ShowModal(const ACommonDialog: TCommonDialog);
var
State: TApplicationState;
lOldWorkingDir, lInitialDir: string;
Dialog: IFileSaveDialog;
begin
if (ACommonDialog.Handle <> 0) and (ACommonDialog.Handle <> INVALID_HANDLE_VALUE) then
begin
State := SaveApplicationState;
lOldWorkingDir := GetCurrentDirUTF8;
try
lInitialDir := TSaveDialog(ACommonDialog).InitialDir;
if lInitialDir <> '' then
SetCurrentDirUTF8(lInitialDir);
if CanUseVistaDialogs(TOpenDialog(ACommonDialog)) and not IsXPStyleFallBack(TOpenDialog(ACommonDialog)) then
begin
Dialog := IFileSaveDialog(ACommonDialog.Handle);
TWin32WSOpenDialog.VistaDialogShowModal(Dialog, TOpenDialog(ACommonDialog));
end
else
begin
ProcessFileDialogResult(TOpenDialog(ACommonDialog),
GetSaveFileNameW(LPOPENFILENAME(ACommonDialog.Handle)));
end;
finally
SetCurrentDirUTF8(lOldWorkingDir);
RestoreApplicationState(State);
end;
end;
end;
class function TWin32WSSaveDialog.QueryWSEventCapabilities(
const ACommonDialog: TCommonDialog): TCDWSEventCapabilities;
begin
Result := [cdecWSPerformsDoShow,cdecWSPerformsDoCanClose];
end;
{ TWin32WSFontDialog }
function FontDialogCallBack(Wnd: HWND; uMsg: UINT; wParam: WPARAM;
lParam: LPARAM): UINT_PTR; stdcall;
const
//These ID's can be seen as LoWord(wParam), when uMsg = WM_COMMAND
ApplyBtnControlID = 1026;
ColorComboBoxControlID = 1139; //see also: https://www.experts-exchange.com/questions/27267157/Font-Common-Dialog.html
//don't use initialize "var", since that will be reset to nil at every callback
Dlg: ^TFontDialog = nil;
var
LFW: LogFontW;
LFA: LogFontA absolute LFW;
Res: LONG;
AColor: TColor;
begin
Result := 0;
case uMsg of
WM_INITDIALOG:
begin
//debugln(['FontDialogCallBack: WM_INITDIALOG']);
//debugln([' PChooseFontW(LParam)^.lCustData=',IntToHex(PChooseFontW(LParam)^.lCustData,8)]);
Dlg := Pointer(PChooseFontW(LParam)^.lCustData);
end;
WM_COMMAND:
begin
//debugln(['FontDialogCallBack:']);
//debugln([' wParam=',wParam,' lParam=',lParam]);
//debugln([' HiWord(wParam)=',HiWord(wParam),' LoWord(wParam)',LoWord(wParam)]);
//debugln([' HiWord(lParam)=',HiWord(lParam),' LoWord(lParam)',LoWord(lParam)]);
// LoWord(wParam) must be ApplyBtnControlID,
// since HiWord(wParam) = 0 when button is clicked, wParam = LoWord(wParam) in this case
if (wParam = ApplyBtnControlID) then
begin
//debugln(['FontDialogCallback calling OnApplyClicked']);
if Assigned(Dlg) and Assigned(Dlg^) then
begin
if Assigned(Dlg^.OnApplyClicked) then
begin
//Query the dialog (Wnd) return a LogFont structure
//https://msdn.microsoft.com/en-us/library/windows/desktop/ms646880(v=vs.85).aspx
ZeroMemory(@LFW, SizeOf(LogFontW));
SendMessage(Wnd, WM_CHOOSEFONT_GETLOGFONT, 0, PtrInt(@LFW));
//Unfortunately this did NOT retrieve the Color information, so yet another query is necessary
AColor := Dlg^.Font.Color;
Res := SendDlgItemMessage(Wnd, ColorComboBoxControlID, CB_GETCURSEL, 0, 0);
//debugln(['FontDialogCallBack SendDlgItemMessage = ',Res]);
//if (Res=CB_ERR) then debugln(' = CB_ERR');
if (Res <> CB_ERR) then
begin
AColor := TColor(SendDlgItemMessage(Wnd, ColorComboBoxControlID, CB_GETITEMDATA, Res, 0));
//debugln(['FontDialogCallback SendDlgItemMessage =',AColor]);
end;
//Now finally update Dlg^.Font structure
LFA.lfFaceName := Utf16ToUtf8(LFW.lfFaceName);
Dlg^.Font.Assign(LFA);
Dlg^.Font.Color := AColor;
Dlg^.OnApplyClicked(Dlg^);
Result := 1;
end;
end;
end;
end;
end;
end;
class function TWin32WSFontDialog.CreateHandle(const ACommonDialog: TCommonDialog): THandle;
function GetFlagsFromOptions(Options : TFontDialogOptions): dword;
begin
Result := 0;
if fdAnsiOnly in Options then Result := Result or CF_ANSIONLY;
if fdTrueTypeOnly in Options then Result := Result or CF_TTONLY;
if fdEffects in Options then Result := Result or CF_EFFECTS;
if fdFixedPitchOnly in Options then Result := Result or CF_FIXEDPITCHONLY;
if fdForceFontExist in Options then Result := Result or CF_FORCEFONTEXIST;
if fdNoFaceSel in Options then Result := Result or CF_NOFACESEL;
if fdNoOEMFonts in Options then Result := Result or CF_NOOEMFONTS;
if fdNoSimulations in Options then Result := Result or CF_NOSIMULATIONS;
if fdNoSizeSel in Options then Result := Result or CF_NOSIZESEL;
if fdNoStyleSel in Options then Result := Result or CF_NOSTYLESEL;
if fdNoVectorFonts in Options then Result := Result or CF_NOVECTORFONTS;
if fdShowHelp in Options then Result := Result or CF_SHOWHELP;
if fdWysiwyg in Options then Result := Result or CF_WYSIWYG;
if fdLimitSize in Options then Result := Result or CF_LIMITSIZE;
if fdScalableOnly in Options then Result := Result or CF_SCALABLEONLY;
if fdApplyButton in Options then Result := Result or CF_APPLY;
end;
var
CFW: TChooseFontW;
LFW: LogFontW;
CF: TChooseFontA absolute CFW;
LF: LogFontA absolute LFW;
UserResult: WINBOOL;
TempName: String;
begin
with TFontDialog(ACommonDialog) do
begin
ZeroMemory(@CFW, sizeof(TChooseFontW));
ZeroMemory(@LFW, sizeof(LogFontW));
with LFW do
begin
LFHeight := Font.Height;
LFFaceName := UTF8ToUTF16(Font.Name);
if (fsBold in Font.Style) then LFWeight:= FW_BOLD;
LFItalic := byte(fsItalic in Font.Style);
LFStrikeOut := byte(fsStrikeOut in Font.Style);
LFUnderline := byte(fsUnderline in Font.Style);
LFCharSet := Font.CharSet;
end;
// Duplicate logic in CreateFontIndirect
if not Win32WidgetSet.MetricsFailed and IsFontNameDefault(Font.Name) then
begin
LFW.lfFaceName := UTF8ToUTF16(Win32WidgetSet.Metrics.lfMessageFont.lfFaceName);
if LFW.lfHeight = 0 then
LFW.lfHeight := Win32WidgetSet.Metrics.lfMessageFont.lfHeight;
end;
with CFW do
begin
LStructSize := sizeof(TChooseFont);
HWndOwner := GetOwnerHandle(ACommonDialog);
LPLogFont := commdlg.PLOGFONTW(@LFW);
Flags := GetFlagsFromOptions(Options);
Flags := Flags or CF_INITTOLOGFONTSTRUCT or CF_BOTH;
//setting CF_ENABLEHOOK shows an oldstyle dialog, unless lpTemplateName is set
//and a template is linked in as a resource,
//this also requires additional flas set:
//https://msdn.microsoft.com/en-us/library/windows/desktop/ms646832(v=vs.85).aspx
if (fdApplyButton in Options) then
begin
Flags := Flags or CF_ENABLEHOOK;
lpfnHook := @FontDialogCallBack;
lCustData := PtrInt(@ACommonDialog);
end;
RGBColors := ColorToRGB(Font.Color);
if fdLimitSize in Options then
begin
nSizeMin := MinFontSize;
nSizeMax := MaxFontSize;
end;
end;
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSFontDialog.CreateHandle calling DoShow']);
{$endif}
TFontDialog(ACommonDialog).DoShow;
UserResult := ChooseFontW(LPCHOOSEFONT(@CFW)); // ChooseFontW signature may be wrong.
// we need to update LF now
LF.lfFaceName := UTF16ToUTF8(LFW.lfFaceName);
end;
SetDialogResult(ACommonDialog, UserResult);
if UserResult then
begin
with TFontDialog(ACommonDialog).Font do
begin
if not Win32WidgetSet.MetricsFailed and IsFontNameDefault(Name) then
begin
if Sysutils.strlcomp(
@Win32WidgetSet.Metrics.lfMessageFont.lfFaceName[0],
@LF.lfFaceName[0],
Length(LF.lfFaceName)) = 0 then
begin
TempName := Name; // Dialog.Font.Name is a property and has getter method.
Sysutils.StrLCopy(@LF.lfFaceName[0], PChar(TempName), Length(LF.lfFaceName));
end;
if LF.lfHeight = Win32WidgetSet.Metrics.lfMessageFont.lfHeight then
LF.lfHeight := 0;
if (CharSet = DEFAULT_CHARSET) and (Win32WidgetSet.Metrics.lfMessageFont.lfCharSet = LF.lfCharSet) then
LF.lfCharSet := DEFAULT_CHARSET;
end;
Assign(LF);
if (CF.rgbColors <> 0) or (Color <> clDefault) then
Color := CF.RGBColors;
end;
end;
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSFontDialog.CreateHandle calling DoClose']);
{$endif}
TFontDialog(ACommonDialog).DoClose;
Result := 0;
end;
class function TWin32WSFontDialog.QueryWSEventCapabilities(
const ACommonDialog: TCommonDialog): TCDWSEventCapabilities;
begin
Result := [cdecWSPerformsDoShow, cdecWSPerformsDoClose, cdecWSNoCanCloseSupport];
end;
{ TWin32WSCommonDialog }
class function TWin32WSCommonDialog.CreateHandle(const ACommonDialog: TCommonDialog): THandle;
begin
Result := 0;
end;
class procedure TWin32WSCommonDialog.DestroyHandle(const ACommonDialog: TCommonDialog);
begin
DestroyWindow(ACommonDialog.Handle);
end;
{ TWin32WSSelectDirectoryDialog }
{------------------------------------------------------------------------------
Function: BrowseForFolderCallback
Params: Window_hwnd - The window that receives a message for the window
Msg - The message received
LParam - Long-integer parameter
lpData - Data parameter, contains initial path.
Returns: non-zero long-integer
Handles the messages sent to the toolbar button by Windows
------------------------------------------------------------------------------}
function BrowseForFolderCallback(hwnd : Handle; uMsg : UINT;
{%H-}lParam, lpData : LPARAM) : Integer; stdcall;
begin
case uMsg of
BFFM_INITIALIZED:
// Setting root dir
SendMessageW(hwnd, BFFM_SETSELECTIONW, WPARAM(True), lpData);
//BFFM_SELCHANGED
// : begin
// if Assigned(FOnSelectionChange) then .....
// end;
end;
Result := 0;
end;
class function TWin32WSSelectDirectoryDialog.CreateHandle(const ACommonDialog: TCommonDialog): THandle;
var
Dialog: IFileOpenDialog;
begin
if CanUseVistaDialogs(TOpenDialog(ACommonDialog)) then
begin
WidgetSet.AppInit(ScreenInfo);
if Succeeded(CoCreateInstance(CLSID_FileOpenDialog, nil, CLSCTX_INPROC_SERVER, IFileOpenDialog, Dialog)) and Assigned(Dialog) then
begin
Dialog._AddRef;
TWin32WSOpenDialog.SetupVistaFileDialog(Dialog, TOpenDialog(ACommonDialog));
Result := THandle(Dialog);
end
else
Result := INVALID_HANDLE_VALUE;
end
else
Result := CreateOldHandle(ACommonDialog);
end;
class function TWin32WSSelectDirectoryDialog.QueryWSEventCapabilities(
const ACommonDialog: TCommonDialog): TCDWSEventCapabilities;
begin
if CanUseVistaDialogs(TSelectDirectoryDialog(ACommonDialog)) then
Result := [cdecWSPerformsDoShow,cdecWSPerformsDoCanClose]
else
Result := [cdecWSPerformsDoShow, cdecWSPerformsDoClose, cdecWSNoCanCloseSupport];
end;
class function TWin32WSSelectDirectoryDialog.CreateOldHandle(
const ACommonDialog: TCommonDialog): THandle;
var
Options : TOpenOptions;
InitialDir : string;
Buffer : PChar;
iidl : PItemIDList;
biw : TBROWSEINFOW;
Bufferw : PWideChar absolute Buffer;
InitialDirW: widestring;
Title: widestring;
DirName: string;
begin
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSSelectDirectoryDialog.CreateOldHandle A']);
{$endif}
DirName := '';
InitialDir := TSelectDirectoryDialog(ACommonDialog).FileName;
Options := TSelectDirectoryDialog(ACommonDialog).Options;
if length(InitialDir)=0 then
InitialDir := TSelectDirectoryDialog(ACommonDialog).InitialDir;
if length(InitialDir)>0 then begin
// remove the \ at the end.
if Copy(InitialDir,length(InitialDir),1)=PathDelim then
InitialDir := copy(InitialDir,1, length(InitialDir)-1);
// if it is a rootdirectory, then the InitialDir must have a \ at the end.
if Copy(InitialDir,length(InitialDir),1)=DriveDelim then
InitialDir := InitialDir + PathDelim;
end;
Buffer := CoTaskMemAlloc(MAX_PATH*2);
InitialDirW:=UTF8ToUTF16(InitialDir);
with biw do
begin
hwndOwner := GetOwnerHandle(ACommonDialog);
pidlRoot := nil;
pszDisplayName := BufferW;
Title := UTF8ToUTF16(ACommonDialog.Title);
lpszTitle := PWideChar(Title);
ulFlags := BIF_RETURNONLYFSDIRS;
if not (ofCreatePrompt in Options) then
ulFlags := ulFlags + BIF_NONEWFOLDERBUTTON;
if (ofEnableSizing in Options) then
// better than flag BIF_USENEWUI, to hide editbox, it's not handy
ulFlags := ulFlags + BIF_NEWDIALOGSTYLE;
lpfn := @BrowseForFolderCallback;
// this value will be passed to callback proc as lpData
lParam := Windows.LParam(PWideChar(InitialDirW));
end;
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSSelectDirectoryDialog.CreateOldHandle calling DoShow']);
{$endif}
TSelectDirectoryDialog(ACommonDialog).DoShow;
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSSelectDirectoryDialog.CreateOldHandle before SHBrowseForFolder']);
{$endif}
iidl := SHBrowseForFolderW(@biw);
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSSelectDirectoryDialog.CreateOldHandle after SHBrowseForFolder']);
{$endif}
if Assigned(iidl) then
begin
SHGetPathFromIDListW(iidl, BufferW);
CoTaskMemFree(iidl);
DirName := UTF16ToUTF8(widestring(BufferW));
end;
if Assigned(iidl) then
begin
TSelectDirectoryDialog(ACommonDialog).FileName := DirName;
TSelectDirectoryDialog(ACommonDialog).Files.Text := DirName;
end;
SetDialogResult(ACommonDialog, assigned(iidl));
CoTaskMemFree(Buffer);
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSSelectDirectoryDialog.CreateOldHandle calling DoClose']);
{$endif}
TSelectDirectoryDialog(ACommonDialog).DoClose;
Result := 0;
{$ifdef DebugCommonDialogEvents}
debugln(['TWin32WSSelectDirectoryDialog.CreateOldHandle End']);
{$endif}
end;
{ TFileDialogEvents }
// Only gets called when user clicks OK in IFileDialog
function TFileDialogEvents.OnFileOk(pfd: IFileDialog): HResult; stdcall;
var
CanClose: Boolean;
begin
{$ifdef DebugCommonDialogEvents}
debugln('TFileDialogEvents.OnFileOk A');
{$endif}
Result := TWin32WSOpenDialog.ProcessVistaDialogResult(pfd, FDialog);
if Succeeded(Result) then
begin
FDialog.UserChoice := mrOK; //DoCanClose needs this
CanClose := True;
{$ifdef DebugCommonDialogEvents}
debugln('TFileDialogEvents.OnFileOk: calling DoCanClose');
{$endif}
FDialog.DoCanClose(CanClose);
if CanClose then
begin
Result := S_OK;
end
else
begin
FDialog.UserChoice := mrNone;
Result := S_FALSE;
end;
end;
{$ifdef DebugCommonDialogEvents}
debugln('TFileDialogEvents.OnFileOk End');
{$endif}
end;
function TFileDialogEvents.OnFolderChanging(pfd: IFileDialog; psifolder: IShellItem): HResult; stdcall;
begin
Result := S_OK;
end;
function TFileDialogEvents.OnFolderChange(pfd: IFileDialog): HResult; stdcall;
//var
// ShellItem: IShellItem;
begin
//Result := pfd.Getfolder(@ShellItem);
//if Succeeded(Result) then
//begin
// FDialog.Files.Clear;
// FDialog.FileName := TWin32WSOpenDialog.GetFileName(ShellItem);
// FDialog.Files.Add(FDialog.FileName);
// FDialog.DoFolderChange;
// end;
FDialog.DoFolderChange;
Result := S_OK;
end;
function TFileDialogEvents.OnSelectionChange(pfd: IFileDialog): HResult; stdcall;
var
ShellItem: IShellItem;
begin
Result := pfd.GetCurrentSelection(@ShellItem);
if Succeeded(Result) then
begin
FDialog.Files.Clear;
FDialog.FileName := TWin32WSOpenDialog.GetFileName(ShellItem);
FDialog.Files.Add(FDialog.FileName);
FDialog.DoSelectionChange;
end;
end;
function TFileDialogEvents.OnShareViolation(pfd: IFileDialog; psi: IShellItem; pResponse: pFDE_SHAREVIOLATION_RESPONSE): HResult; stdcall;
begin
Result := S_OK;
end;
function TFileDialogEvents.OnTypeChange(pfd: IFileDialog): HResult; stdcall;
var
NewIndex: UINT;
begin
Result := pfd.GetFileTypeIndex(@NewIndex);
if Succeeded(Result) then
FDialog.IntfFileTypeChanged(NewIndex);
end;
function TFileDialogEvents.OnOverwrite(pfd: IFileDialog; psi: IShellItem; pResponse: pFDE_OVERWRITE_RESPONSE): HResult; stdcall;
begin
Result := S_OK;
end;
function TFileDialogEvents.OnItemSelected(pfdc: IFileDialogCustomize; dwIDCtl: DWORD; dwIDItem: DWORD): HResult; stdcall;
begin
Result := S_OK;
end;
function TFileDialogEvents.OnButtonClicked(pfdc: IFileDialogCustomize; dwIDCtl: DWORD): HResult; stdcall;
begin
Result := S_OK;
end;
function TFileDialogEvents.OnCheckButtonToggled(pfdc: IFileDialogCustomize; dwIDCtl: DWORD; bChecked: BOOL): HResult; stdcall;
begin
Result := S_OK;
end;
function TFileDialogEvents.OnControlActivating(pfdc: IFileDialogCustomize; dwIDCtl: DWORD): HResult; stdcall;
begin
Result := S_OK;
end;
constructor TFileDialogEvents.Create(ADialog: TOpenDialog);
begin
inherited Create;
FDialog := ADialog;
end;
{ TWin32WSTaskDialog }
var
//TaskDialogIndirect: function(AConfig: pointer; Res: PInteger;
// ResRadio: PInteger; VerifyFlag: PBOOL): HRESULT; stdcall;
TaskDialogIndirectAvailable: Boolean = False;
function TaskDialogFlagsToInteger(aFlags: TTaskDialogFlags): Integer;
const
//missing from CommCtrls in fpc < 3.3.1
TDF_NO_SET_FOREGROUND = $10000;
TDF_SIZE_TO_CONTENT = $1000000;
{
tfEnableHyperlinks, tfUseHiconMain,
tfUseHiconFooter, tfAllowDialogCancellation,
tfUseCommandLinks, tfUseCommandLinksNoIcon,
tfExpandFooterArea, tfExpandedByDefault,
tfVerificationFlagChecked, tfShowProgressBar,
tfShowMarqueeProgressBar, tfCallbackTimer,
tfPositionRelativeToWindow, tfRtlLayout,
tfNoDefaultRadioButton, tfCanBeMinimized,
tfNoSetForeGround, tfSizeToContent,
tfForceNonNative, tfEmulateClassicStyle);
}
FlagValues: Array[TTaskDialogFlag] of Integer = (
TDF_ENABLE_HYPERLINKS, TDF_USE_HICON_MAIN,
TDF_USE_HICON_FOOTER, TDF_ALLOW_DIALOG_CANCELLATION,
TDF_USE_COMMAND_LINKS, TDF_USE_COMMAND_LINKS_NO_ICON,
TDF_EXPAND_FOOTER_AREA, TDF_EXPANDED_BY_DEFAULT,
TDF_VERIFICATION_FLAG_CHECKED, TDF_SHOW_PROGRESS_BAR,
TDF_SHOW_MARQUEE_PROGRESS_BAR, TDF_CALLBACK_TIMER,
TDF_POSITION_RELATIVE_TO_WINDOW, TDF_RTL_LAYOUT,
TDF_NO_DEFAULT_RADIO_BUTTON, TDF_CAN_BE_MINIMIZED,
TDF_NO_SET_FOREGROUND {added in Windows 8}, TDF_SIZE_TO_CONTENT,
//custom LCL flags
0 {tfForceNonNative}, 0 {tfEmulateClassicStyle},
0,{tfQuery} 0 {tfSimpleQuery}, 0 {tfQueryFixedChoices}, 0 {tfQueryFocused});
var
aFlag: TTaskDialogFlag;
begin
Result := 0;
for aFlag := Low(TTaskDialogFlags) to High(TTaskDialogFlags) do
if (aFlag in aFlags) then
Result := Result or FlagValues[aFlag];
end;
function TaskDialogCommonButtonsToInteger(const Buttons: TTaskDialogCommonButtons): Integer;
const
CommonButtonValues: Array[TTaskDialogCommonButton] of Integer = (
TDCBF_OK_BUTTON,// tcbOk
TDCBF_YES_BUTTON, //tcbYes
TDCBF_NO_BUTTON, //tcbNo
TDCBF_CANCEL_BUTTON, //tcbCancel
TDCBF_RETRY_BUTTON, //tcbRetry
TDCBF_CLOSE_BUTTON //tcbClose
);
var
B: TTaskDialogCommonButton;
begin
Result := 0;
for B in TTaskDialogCommonButton do
begin
if B in Buttons then
Result := Result or CommonButtonValues[B];
end;
end;
function DialogBaseUnits: Integer;
//https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getdialogbaseunits
type
TLongRec = record L, H: Word; end;
begin
Result := TLongRec(GetDialogBaseUnits).L;
end;
type
TTaskDialogAccess = class(TCustomTaskDialog)
end;
function TaskDialogCallbackProc({%H-}hwnd: HWND; uNotification: UINT;
wParam: WPARAM; {%H-}lParam: LPARAM; dwRefData: Long_Ptr): HRESULT; stdcall;
var
Dlg: TTaskDialog absolute dwRefData;
CanClose, ResetTimer: Boolean;
AUrl: String;
begin
Result := S_OK;
case uNotification of
TDN_DIALOG_CONSTRUCTED:
begin
Assert((Dlg is TCustomTaskDialog),'TaskDialogCallbackProc: dwRefData is NOT a TCustomTaskDialog');
{$PUSH}
{$ObjectChecks OFF}
//testing shows that hwnd is the same in all notifications
//and since TDN_DIALOG_CONSTRUCTED comes first, just set it here
//so any OnTaskDialogxxx event will have access to the correct handle.
TTaskDialogAccess(Dlg).InternalSetDialogHandle(hwnd);
TTaskDialogAccess(Dlg).DoOnDialogConstructed;
{$POP}
end;
TDN_CREATED:
begin
Assert((Dlg is TCustomTaskDialog),'TaskDialogCallbackProc: dwRefData is NOT a TCustomTaskDialog');
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnDialogCreated;
{$POP}
end;
TDN_DESTROYED:
begin
Assert((Dlg is TCustomTaskDialog),'TaskDialogCallbackProc: dwRefData is NOT a TCustomTaskDialog');
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnDialogDestroyed;
{$POP}
end;
TDN_BUTTON_CLICKED:
begin
Assert((Dlg is TCustomTaskDialog),'TaskDialogCallbackProc: dwRefData is NOT a TCustomTaskDialog');
CanClose := True;
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnButtonClicked(Dlg.ButtonIDToModalResult(wParam), CanClose);
if not CanClose then
Result := S_FALSE;
{$POP}
end;
TDN_HYPERLINK_CLICKED:
begin
{
wParam: Must be zero.
lParam: Pointer to a wide-character string containing the URL of the hyperlink.
Return value: The return value is ignored.
}
AUrl := Utf16ToUtf8(PWideChar(lParam)); // <== can this be done safely and passed to OnUrlClicked if AUrls is a local variable here??
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnHyperlinkClicked(AUrl);
{$POP}
end;
TDN_NAVIGATED:
begin
{
wParam: Must be zero.
lParam: Must be zero.
Return value: The return value is ignored.
}
Assert((Dlg is TCustomTaskDialog),'TaskDialogCallbackProc: dwRefData is NOT a TCustomTaskDialog');
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnNavigated;
{$POP}
end;
TDN_TIMER:
begin
{
wParam: A DWORD that specifies the number of milliseconds since the dialog was created or this notification code returned S_FALSE.
lParam: Must be zero.
Return value: To reset the tickcount, the application must return S_FALSE, otherwise the tickcount will continue to increment.
}
Assert((Dlg is TCustomTaskDialog),'TaskDialogCallbackProc: dwRefData is NOT a TCustomTaskDialog');
ResetTimer := False;
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnTimer(Cardinal(wParam), ResetTimer);
{$POP}
if ResetTimer then
Result := S_FALSE;
end;
TDN_VERIFICATION_CLICKED:
begin
Assert((Dlg is TCustomTaskDialog),'TaskDialogCallbackProc: dwRefData is NOT a TCustomTaskDialog');
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnverificationClicked(BOOL(wParam));
{$POP}
end;
TDN_EXPANDO_BUTTON_CLICKED:
begin
Assert((Dlg is TCustomTaskDialog),'TaskDialogCallbackProc: dwRefData is NOT a TCustomTaskDialog');
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnExpandButtonClicked(BOOL(wParam));
{$POP}
end;
TDN_RADIO_BUTTON_CLICKED:
begin
{
wParam: An int that specifies the ID corresponding to the radio button that was clicked.
lParam: Must be zero.
Return value: The return value is ignored.
}
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnRadioButtonClicked(wParam);
{$POP}
end;
TDN_HELP:
begin
Assert((Dlg is TCustomTaskDialog),'TaskDialogCallbackProc: dwRefData is NOT a TCustomTaskDialog');
{$PUSH}
{$ObjectChecks OFF}
TTaskDialogAccess(Dlg).DoOnHelp;
{$POP}
end;
end;
end;
type
TWideStringArray = array of WideString;
TButtonArray = array of TTASKDIALOG_BUTTON;
class function TWin32WSTaskDialog.Execute(const ADlg: TCustomTaskDialog; AParentWnd: HWND; out ARadioRes: Integer): Integer;
var
Config: TTASKDIALOGCONFIG;
VerifyChecked: BOOL;
ButtonCaptions: TWideStringArray;
Buttons: TButtonArray;
WindowTitle, MainInstruction, Content, VerificationText,
ExpandedInformation, ExpandedControlText, CollapsedControlText,
Footer: WideString;
DefRB, DefBtn, RUCount: Integer;
CommonButtons: TTaskDialogCommonButtons;
Flags: TTaskDialogFlags;
Res: HRESULT;
procedure PrepareTaskDialogConfig;
const
TD_BTNMOD: array[TTaskDialogCommonButton] of Integer = (
mrOk, mrYes, mrNo, mrCancel, mrRetry, mrAbort);
//TD_ICONS: array[TLCLTaskDialogIcon] of integer = (
// 0 {tiBlank}, 84 {tiWarning}, 99 {tiQuestion}, 98 {tiError}, 81 {tiInformation}, 0 {tiNotUsed}, 78 {tiShield});
//TD_FOOTERICONS: array[TLCLTaskDialogFooterIcon] of integer = (
// 0 {tfiBlank}, 84 {tfiWarning}, 99 {tfiQuestion}, 98 {tfiError}, 65533 {tfiInformation}, 65532 {tfiShield});
TD_ICONS: array[TTaskDialogIcon] of MAKEINTRESOURCEW = (
nil, TD_WARNING_ICON, TD_ERROR_ICON, TD_INFORMATION_ICON, TD_SHIELD_ICON, TD_QUESTION_ICON
);
procedure AddTaskDiakogButton(Btns: TTaskDialogButtons; var n: longword; firstID: integer);
var
i: Integer;
begin
if (Btns.Count = 0) then
Exit;
for i := 0 to Btns.Count - 1 do
begin
if Length(ButtonCaptions)<=RUCount then
begin
SetLength(ButtonCaptions,RUCount+16);
SetLength(Buttons,RUCount+16);
end;
//disable this for now: what if a caption were to be 'Save to "c:\new_folder\new.work"'' ??
//remove later
//ButtonCaptions[RUCount] := Utf8ToUtf16(StringReplace(Btns.Items[i].Caption,'\n',#10,[rfReplaceAll]));
ButtonCaptions[RUCount] := Utf8ToUtf16(Btns.Items[i].Caption);
if (Btns.Items[i] is TTaskDialogButtonItem) and (tfUseCommandLinks in ADlg.Flags) then
begin
ButtonCaptions[RUCount] := ButtonCaptions[RUCount] + Utf8ToUtf16(#10 + Btns.Items[i].CommandLinkHint);
end;
Buttons[RUCount].nButtonID := n+firstID;
Buttons[RUCount].pszButtonText := PWideChar(ButtonCaptions[RUCount]);
inc(n);
inc(RUCount);
end;
end;
begin
WindowTitle := Utf8ToUtf16(ADlg.Caption);
if (WindowTitle = '') then
begin
if (Application.MainForm = nil) then
WindowTitle := Utf8ToUtf16(Application.Title)
else
WindowTitle := Utf8ToUtf16(Application.MainForm.Caption);
end;
MainInstruction := Utf8ToUtf16(ADlg.Title);
if (MainInstruction = '') then
MainInstruction := Utf8ToUtf16(IconMessage(ADlg.MainIcon));
Content := Utf8ToUtf16(ADlg.Text);
VerificationText := Utf8ToUtf16(ADlg.VerificationText);
if (AParentWnd = 0) then
begin
if Assigned(Screen.ActiveCustomForm) then
AParentWnd := Screen.ActiveCustomForm.Handle
else
AParentWnd := 0;
end;
ExpandedInformation := Utf8ToUtf16(ADlg.ExpandedText);
CollapsedControlText := Utf8ToUtf16(ADlg.ExpandButtonCaption);
ExpandedControlText := Utf8ToUtf16(ADlg.CollapseButtonCaption);
Footer := Utf8ToUtf16(ADlg.FooterText);
if ADlg.RadioButtons.DefaultButton<> nil then
DefRB := ADlg.RadioButtons.DefaultButton.Index
else
DefRB := 0;
if ADlg.Buttons.DefaultButton<>nil then
DefBtn := ADlg.Buttons.DefaultButton.Index + TaskDialogFirstButtonIndex
else
DefBtn := TD_BTNMOD[ADlg.DefaultButton];
if (ADlg.CommonButtons = []) and (ADlg.Buttons.Count = 0) then
begin
CommonButtons := [tcbOk];
if (DefBtn = 0) then
DefBtn := mrOK;
end;
Config := Default(TTaskDialogConfig);
Config.cbSize := SizeOf(TTaskDialogConfig);
Config.hwndParent := AParentWnd;
Config.pszWindowTitle := PWideChar(WindowTitle);
Config.pszMainInstruction := PWideChar(MainInstruction);
Config.pszContent := PWideChar(Content);
Config.pszVerificationText := PWideChar(VerificationText);
Config.pszExpandedInformation := PWideChar(ExpandedInformation);
Config.pszCollapsedControlText := PWideChar(CollapsedControlText);
Config.pszExpandedControlText := PWideChar(ExpandedControlText);
Config.pszFooter := PWideChar(Footer);
Config.nDefaultButton := DefBtn;
RUCount := 0;
AddTaskDiakogButton(ADlg.Buttons,Config.cButtons,TaskDialogFirstButtonIndex);
AddTaskDiakogButton(ADlg.RadioButtons,Config.cRadioButtons,TaskDialogFirstRadioButtonIndex);
if (Config.cButtons > 0) then
Config.pButtons := @Buttons[0];
if (Config.cRadioButtons > 0) then
Config.pRadioButtons := @Buttons[Config.cButtons];
Config.dwCommonButtons := TaskDialogCommonButtonsToInteger(ADlg.CommonButtons);
Flags := ADlg.Flags;
if (VerificationText <> '') and (tfVerificationFlagChecked in ADlg.Flags) then
Include(Flags,tfVerificationFlagChecked)
else
Exclude(Flags,tfVerificationFlagChecked);
if (Config.cButtons=0) and (CommonButtons=[tcbOk]) then
Include(Flags,tfAllowDialogCancellation); // just OK -> Esc/Alt+F4 close
//while the MS docs say that this flag is ignored if Config.cButtons = 0,
//in practice it will make TaskDialogIndirect fail with E_INVALIDARG
if (ADlg.Buttons.Count = 0) then
Exclude(Flags, tfUseCommandLinks);
Config.dwFlags := TaskDialogFlagsToInteger(Flags);
if not (tfUseHIconMain in Flags) then
Config.pszMainIcon := TD_ICONS[ADlg.MainIcon]
else
begin
if Assigned(ADlg.CustomMainIcon) then
Config.hMainIcon := ADlg.CustomMainIcon.Handle
else
Config.hMainIcon := 0;
end;
if not (tfUseHIconFooter in Flags) then
Config.pszFooterIcon := TD_ICONS[ADlg.FooterIcon]
else
begin
if Assigned(ADlg.CustomFooterIcon) then
Config.hFooterIcon := ADlg.CustomFooterIcon.Handle
else
Config.hFooterIcon := 0;
end;
{
Although the offcial MS docs (https://learn.microsoft.com/en-us/windows/win32/api/commctrl/ns-commctrl-taskdialogconfig)
states that setting the flag TDF_NO_DEFAULT_RADIO_BUTTON should cause that no radiobutton
is selected when the dialog displays, testing shows that (at least on Win10) this only
works correctly if nDefaultRadioButton does NOT point to a radiobutton in the pRadioButtons array.
}
if not (tfNoDefaultRadioButton in ADlg.Flags) then
Config.nDefaultRadioButton := DefRB + TaskDialogFirstRadioButtonIndex;
if not (tfSizeToContent in ADlg.Flags) then
Config.cxWidth := MulDiv(ADlg.Width, 4, DialogBaseUnits) // cxWidth needed in "dialog units"
else
Config.cxWidth := 0; // see: https://learn.microsoft.com/en-us/windows/win32/api/commctrl/ns-commctrl-taskdialogconfig
Config.pfCallback := @TaskDialogCallbackProc;
Config.lpCallbackData := LONG_PTR(ADlg);
end;
begin
//if IsConsole then writeln('TWin32WSTaskDialog.Execute A');
//if not Assigned(TaskDialogIndirect) or
if not TaskDialogIndirectAvailable or
(tfForceNonNative in ADlg.Flags) or
((tfQuery in ADlg.Flags) and (ADlg.QueryChoices.Count > 0)) or
((tfSimpleQuery in ADlg.Flags) and (ADlg.SimpleQuery <> ''))
then
Result := inherited Execute(ADlg, AParentWnd, ARadioRes)
else
begin
ARadioRes := 0;
PrepareTaskDialogConfig;//(TTaskDialog(ADlg), AParentWnd, Config, ButtonCaptions, Buttons);
Res := TaskDialogIndirect(@Config, @Result, @ARadioRes, @VerifyChecked);
if (Res = S_OK) then
begin
if VerifyChecked then
ADlg.Flags := ADlg.Flags + [tfVerificationFlagChecked]
else
ADlg.Flags := ADlg.Flags - [tfVerificationFlagChecked]
end
else
begin
if IsConsole then writeln('TWin32WSTaskDialog.Execute: Call to TaskDialogIndirect failed, result was: ',LongInt(Res).ToHexString,' [',Res,']');
Result := inherited Execute(ADlg, AParentWnd, ARadioRes); //probably illegal parameters: fallback to emulated taskdialog
end;
end;
end;
procedure InitTaskDialogIndirect;
var
OSVersionInfo: TOSVersionInfo;
Res: HRESULT;
{$IFDEF VerboseTaskDialog}
DbgOutput: string;
{$ENDIF}
begin
//There is no need to get the address of TaskDialogIndirect.
//CommCtrl already has TaskDialogIndirect, which returns E_NOTIMPL if this function is not available in 'comctl32.dll'
//We could check that in order to initilaize our TaskDialogIndirect variable.
//We shouldn't however set CommCtrl.TaskDialogIndirect to nil, other (third party) code may rely on in not ever being nil.
Res := TaskDialogIndirect(nil,nil,nil,nil);
{$IFDEF VerboseTaskDialog}
DbgOutput := 'InitTaskDialogIndirect: TaskDialogIndirect(nil,nil,nil,nil)=$' + LongInt(Res).ToHexString;
if (Res = E_INVALIDARG) then
DbgOutput := DbgOutput + ' (=E_INVALIDARG)';
DebugLn(DbgOutput);
{$ENDIF}
TaskDialogIndirectAvailable := (Res = E_INVALIDARG);//(Res <> E_NOTIMPL);
{$IFDEF VerboseTaskDialog}
DebugLn('InitTaskDialogIndirect: TaskDialogIndirectAvailable='+BoolToStr(TaskDialogIndirectAvailable, True));
{$ENDIF}
//OSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo);
//GetVersionEx(OSVersionInfo);
//if OSVersionInfo.dwMajorVersion<6 then
// TaskDialogIndirect := nil else
// Pointer(TaskDialogIndirect) := GetProcAddress(GetModuleHandle(comctl32),'TaskDialogIndirect');
end;
initialization
if (Win32MajorVersion = 4) then
OpenFileNameSize := SizeOf(OPENFILENAME_NT4)
else
OpenFileNameSize := SizeOf(OPENFILENAME);
InitTaskDialogIndirect;
finalization
FreeXPStyleFallBackList
end.
Reference in New Issue View Git Blame Copy Permalink