フォーラム


ゲスト  

ようこそ ゲスト さん。このフォーラムに投稿するには 登録が必要です。

ページ: [1]
トピック: SelectDirectory (Windows)
DEKO
管理者
投稿数: 2644
SelectDirectory (Windows)
on: 2013/10/29 09:29 Tue

FireMonkey には SelectDirectory() がないのだとか。

[Firemonkey HD Application フォルダ選択ダイアログボックスが無い (Embarcadero Discussion Forums)]
https://forums.embarcadero.com/thread.jspa?threadID=96309

SHBrowseForFolder() をラッピングしたものを使えばいいような気がします。以下の関数は VCL の SelectDirectory() の二番目の方と互換性があります。

[FMX.SelectDirectory.Win.pas]
unit FMX.SelectDirectory.Win;

interface

uses
System.SysUtils, System.UITypes, FMX.Dialogs, FMX.Platform.Win, Winapi.Windows,
Winapi.Messages, Winapi.ShlObj, Winapi.ActiveX, Vcl.Consts;

type
TSelectDirExtOpt = (sdNewFolder, sdShowEdit, sdShowShares, sdNewUI, sdShowFiles, sdValidateDir);
TSelectDirExtOpts = set of TSelectDirExtOpt;

function SelectDirectory(const Caption: string; const Root: WideString;
var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: HWND = 0): Boolean;

implementation

function BrowseFolderCallbackProc(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer; stdcall;
begin
Result := 0;
case uMsg of
BFFM_INITIALIZED:
SendMessage(Wnd, BFFM_SETSELECTION, 1, lpData);
BFFM_VALIDATEFAILEDW,
BFFM_VALIDATEFAILEDA:
begin
MessageDlg(Format(SInvalidPath, [PChar(lParam)]), TMsgDlgType.mtError, [TMsgDlgBtn.mbOK], 0);
Result := 1;
end;
end;
end;

function SelectDirectory(const Caption: string; const Root: WideString;
var Directory: string; Options: TSelectDirExtOpts = [sdNewUI]; Parent: HWND = 0): Boolean;
var
BI: TBrowseInfo;
IDList, RootIDList: PItemIDList;
Dir: array[0..Max_Path] of Char;
IDesktopFolder: IShellFolder;
Eaten, Flags: LongWord;
begin
Result := False;
FillChar(BI, SizeOf(BI), 0);
with BI do
begin
hwndOwner := Parent;
lpfn := @BrowseFolderCallbackProc;
lpszTitle := PChar(Caption);
RootIDList := nil;
if Root <> '' then
begin
SHGetDesktopFolder(IDesktopFolder);
IDesktopFolder.ParseDisplayName(Parent, nil, POleStr(Root), Eaten, RootIDList, Flags);
end;
pidlRoot := RootIDList;
ulFlags := BIF_RETURNONLYFSDIRS;
if (sdNewUI in Options) then
begin
ulFlags := ulFlags or BIF_NEWDIALOGSTYLE;
if not (sdNewFolder in Options) then
ulFlags := ulFlags or BIF_NONEWFOLDERBUTTON;
end;
if (sdShowEdit in Options) then
begin
ulFlags := ulFlags or BIF_EDITBOX;
if (sdValidateDir in Options) then
ulFlags := ulFlags or BIF_VALIDATE;
end;
if (sdShowShares in Options) then
ulFlags := ulFlags or BIF_SHAREABLE;
if (sdShowFiles in Options) then
ulFlags := ulFlags or BIF_BROWSEINCLUDEFILES;
lParam := Winapi.Windows.LPARAM(PChar(IncludeTrailingPathDelimiter(Directory)));
end;
IDList := SHBrowseForFolder(BI);
if IDList <> nil then
begin
SHGetPathFromIDList(IDList, Dir);
Directory := string(Dir);
Result := True;
end;
end;
end.

 
Vcl.Consts は SInvalidPath 定数のためだけに使われています…FMX.Consts には適当な定数がないのですヨ。多言語化が必要ないのでしたら、ここを直接書き換えてしまえば Vcl.Consts は不要になります。

使い方は以下になります。

uses
..., FMX.Platform.Win, FMX.SelectDirectory.Win;

var
Dir: String;
begin
if SelectDirectory('Caption', '', Dir, [sdNewUI, sdNewFolder], FmxHandleToHWND(Self.Handle)) then
Edit1.Text := Dir;
end;

 
Embarcadero Discussion Forums はしばしば見えなくなるので念のためにこちらにも転記しておきます。

See Also:

[SelectDirectory (DocWiki)]
http://docwiki.embarcadero.com/Libraries/ja/Vcl.FileCtrl.SelectDirectory

[SHBrowseForFolder function (MSDN)]
http://msdn.microsoft.com/en-us/library/windows/desktop/bb762115%28v=vs.85%29.aspx

DEKO
管理者
投稿数: 2644
SelectDirectory (OS X)
on: 2013/10/29 10:51 Tue

OS X の場合には以下の記事を参考にしてください。

[SelectDirectory for OS X (jed-software.com)]
http://jed-software.com/blog/?p=538

DEKO
管理者
投稿数: 2644
SelectDirectory (Win / OS X)
on: 2013/10/30 09:04 Wed

合体させてみました。

FMX.SelectDirectory.pas
unit FMX.SelectDirectory;

interface

uses
System.SysUtils, System.UITypes, FMX.Dialogs,
{$IFDEF MSWINDOWS}
FMX.Platform.Win, Winapi.Windows,
FMX.Forms, Winapi.Messages, Winapi.ShlObj, Winapi.ActiveX, Vcl.Consts;
{$ENDIF}
{$IFDEF MACOS}
FMX.Platform.Mac, Macapi.AppKit, Macapi.Foundation, Macapi.CocoaTypes,
Macapi.ObjectiveC;
{$ENDIF}

type
TSelectDirExtOpt = (sdNewFolder, sdShowEdit, sdShowShares, sdNewUI, sdShowFiles, sdValidateDir);
TSelectDirExtOpts = set of TSelectDirExtOpt;

{$IFDEF MACOS}
NSOpenPanel = interface(NSSavePanel)
['{38052642-8AF2-4F07-B181-0BCEF072082A}']
function URLs: NSArray; cdecl;
function allowsMultipleSelection: Boolean; cdecl;
function canChooseDirectories: Boolean; cdecl;
function canChooseFiles: Boolean; cdecl;
function filenames: NSArray; cdecl;
function resolvesAliases: Boolean; cdecl;
function runModalForTypes(fileTypes: NSArray): NSInteger; cdecl;
procedure setAllowsMultipleSelection(flag: Boolean); cdecl;
procedure setCanChooseDirectories(flag: Boolean); cdecl;
procedure setCanChooseFiles(flag: Boolean); cdecl;
procedure setResolvesAliases(flag: Boolean); cdecl;
procedure _setIncludeNewFolderButton(flag: Boolean); cdecl;
end;
TNSOpenPanel = class(TOCGenericImport<NSOpenPanelClass, NSOpenPanel>) end;
{$ENDIF}

function SelectDirectory(const Caption: string; const Root: WideString;
var Directory: string; Options: TSelectDirExtOpts = [sdNewUI];
Parent: {$IFDEF MSWINDOWS}HWND{$ELSE}UInt32{$ENDIF} = 0): Boolean;

implementation

{$IFDEF MSWINDOWS}
function BrowseFolderCallbackProc(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer; stdcall;
begin
Result := 0;
case uMsg of
BFFM_INITIALIZED:
SendMessage(Wnd, BFFM_SETSELECTION, 1, lpData);
BFFM_VALIDATEFAILEDW,
BFFM_VALIDATEFAILEDA:
begin
MessageDlg(Format(SInvalidPath, [PChar(lParam)]), TMsgDlgType.mtError, [TMsgDlgBtn.mbOK], 0);
Result := 1;
end;
end;
end;
{$ENDIF}

function SelectDirectory(const Caption: string; const Root: WideString;
var Directory: string; Options: TSelectDirExtOpts = [sdNewUI];
Parent: {$IFDEF MSWINDOWS}HWND{$ELSE}UInt32{$ENDIF} = 0): Boolean;
{$IFDEF MSWINDOWS}
var
BI: TBrowseInfo;
IDList, RootIDList: PItemIDList;
Dir: array[0..Max_Path] of Char;
IDesktopFolder: IShellFolder;
Eaten, Flags: LongWord;
{$ENDIF}
{$IFDEF MACOS}
var
LOpenDir: NSOpenPanel;
LInitialDir: NSURL;
LDlgResult: NSInteger;
{$ENDIF}
begin
Result := False;
{$IFDEF MSWINDOWS}
FillChar(BI, SizeOf(BI), 0);
with BI do
begin
hwndOwner := Parent;
lpfn := @BrowseFolderCallbackProc;
lpszTitle := PChar(Caption);
RootIDList := nil;
if Root <> '' then
begin
SHGetDesktopFolder(IDesktopFolder);
IDesktopFolder.ParseDisplayName(Parent, nil,
POleStr(Root), Eaten, RootIDList, Flags);
end;
pidlRoot := RootIDList;
ulFlags := BIF_RETURNONLYFSDIRS;
if (sdNewUI in Options) then
begin
ulFlags := ulFlags or BIF_NEWDIALOGSTYLE;
if not (sdNewFolder in Options) then
ulFlags := ulFlags or BIF_NONEWFOLDERBUTTON;
end;
if (sdShowEdit in Options) then
begin
ulFlags := ulFlags or BIF_EDITBOX;
if (sdValidateDir in Options) then
ulFlags := ulFlags or BIF_VALIDATE;
end;
if (sdShowShares in Options) then
ulFlags := ulFlags or BIF_SHAREABLE;
if (sdShowFiles in Options) then
ulFlags := ulFlags or BIF_BROWSEINCLUDEFILES;
lParam := Winapi.Windows.LPARAM(PChar(IncludeTrailingPathDelimiter(Directory)));
end;
IDList := SHBrowseForFolder(BI);
if IDList <> nil then
begin
SHGetPathFromIDList(IDList, Dir);
Directory := string(Dir);
Result := True;
end;
{$ENDIF}
{$IFDEF MACOS}
// http://jed-software.com/blog/?p=538
LOpenDir := TNSOpenPanel.Wrap(TNSOpenPanel.OCClass.openPanel);
LOpenDir.setAllowsMultipleSelection(False);
LOpenDir.setCanChooseFiles(False);
LOpenDir.setCanChooseDirectories(True);
LOpenDir._setIncludeNewFolderButton((sdNewFolder in Options));
if Directory <> '' then
begin
LInitialDir := TNSURL.Create;
LInitialDir.initFileURLWithPath(NSSTR(Directory));
LOpenDir.setDirectoryURL(LInitialDir);
end;
if Caption <> '' then
LOpenDir.setTitle(NSSTR(Caption));
LOpenDir.retain;
try
LDlgResult := LOpenDir.runModal;
if LDlgResult = NSOKButton then
begin
Directory := string(TNSUrl.Wrap(LOpenDir.URLs.objectAtIndex(0)).relativePath.UTF8String);
Result := True;
end;
finally
LOpenDir.release;
end;
{$ENDIF}
end;

end.

 
OS X の場合には、引数 Root, Parent が意味を持ちません。また、Options に指定できるのは sdNewFolder のみです。OS X の sdNewFolder のためだけにインターフェイスをコピペしています…_setIncludeNewFolderButton() は隠し API なのですヨ。

See Also:
[NSOpenPanel Class Reference (Mac Developer Library)]
https://developer.apple.com/library/mac/documentation/cocoa/reference/applicationkit/Classes/NSOpenPanel_Class/Reference/Reference.html

DEKO
管理者
投稿数: 2644
Re: SelectDirectory (Windows)
on: 2014/07/16 09:45 Wed

XE6 以降では Windows / OS X 用の SelectDirectory() が用意されています。

[FMX.Dialogs.SelectDirectory (DocWiki)]
http://docwiki.embarcadero.com/Libraries/ja/FMX.Dialogs.SelectDirectory

ページ: [1]
WP Forum Server by ForumPress | LucidCrew
バージョン: 1.7.5 ; ページロード: 0.044 sec.