Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- unit Unit1;
- interface
- uses
- Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
- Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.ToolWin, Winapi.ShlObj, Winapi.ActiveX,
- System.IOUtils;
- type
- TMyStrings = array of string;
- TForm1 = class(TForm)
- ToolBar1: TToolBar;
- SelectpathButton: TButton;
- procedure Button1Click(Sender: TObject);
- procedure SelectpathButtonClick(Sender: TObject);
- function GetTextFiles(path:String):TStringList;
- private
- { Private declarations }
- public
- { Public declarations }
- end;
- var
- Form1: TForm1;
- implementation
- {$R *.dfm}
- procedure TForm1.Button1Click(Sender: TObject);
- var
- I: Integer;
- begin
- end;
- function TForm1.GetTextFiles(path: string):TStringList;
- var
- I:Integer;
- Temp_array:TArray<System.string>;
- begin
- Result:=TStringList.Create;
- Temp_array:= TDirectory.GetFiles(path);
- for i:=1 to Length( Temp_array) do
- begin
- if ExtractFileExt(Temp_array[i])='txt' then
- Result.Add(Temp_array[i]);
- end;
- end;
- function AdvSelectDirectory(const Caption: string;
- const Root: WideString; var Directory: string; EditBox: Boolean = False;
- ShowFiles: Boolean = False; AllowCreateDirs: Boolean = True): Boolean;
- function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam)
- : Integer; stdcall;
- begin
- case uMsg of
- BFFM_INITIALIZED:
- SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));
- end;
- Result := 0;
- end;
- var
- WindowList: Pointer;
- BrowseInfo: TBrowseInfo;
- Buffer: PChar;
- RootItemIDList, ItemIDList: PItemIDList;
- ShellMalloc: IMalloc;
- IDesktopFolder: IShellFolder;
- Eaten, Flags: LongWord;
- const
- BIF_USENEWUI = $0040;
- BIF_NOCREATEDIRS = $0200;
- begin
- Result := False;
- if not DirectoryExists(Directory) then
- Directory := '';
- FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
- if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
- begin
- Buffer := ShellMalloc.Alloc(MAX_PATH);
- try
- RootItemIDList := nil;
- if Root <> '' then
- begin
- SHGetDesktopFolder(IDesktopFolder);
- IDesktopFolder.ParseDisplayName(Application.Handle, nil, POleStr(Root),
- Eaten, RootItemIDList, Flags);
- end;
- OleInitialize(nil);
- with BrowseInfo do
- begin
- hwndOwner := Application.Handle;
- pidlRoot := RootItemIDList;
- pszDisplayName := Buffer;
- lpszTitle := PChar(Caption);
- ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI or BIF_EDITBOX *
- Ord(EditBox) or BIF_BROWSEINCLUDEFILES * Ord(ShowFiles) or
- BIF_NOCREATEDIRS * Ord(not AllowCreateDirs);
- lpfn := @SelectDirCB;
- if Directory <> '' then
- lParam := Integer(PChar(Directory));
- end;
- WindowList := DisableTaskWindows(0);
- try
- ItemIDList := ShBrowseForFolder(BrowseInfo);
- finally
- EnableTaskWindows(WindowList);
- end;
- Result := ItemIDList <> nil;
- if Result then
- begin
- ShGetPathFromIDList(ItemIDList, Buffer);
- ShellMalloc.Free(ItemIDList);
- Directory := Buffer;
- end;
- finally
- ShellMalloc.Free(Buffer);
- end;
- end;
- end;
- procedure TForm1.SelectpathButtonClick(Sender: TObject);
- var
- path,Root:String;
- fileList:TStringList;
- begin
- fileList:=TStringList.Create;
- path:='c:\\';
- if AdvSelectDirectory('Выбор папки','',path)=true then
- begin
- fileList:= GetTextFiles(path);
- fileList.Free;
- end;
- end;
- end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement