Опытный
Профиль
Группа: Участник
Сообщений: 436
Регистрация: 30.9.2004
Репутация: нет Всего: 0
|
В общем не стал я использовать TDirectoryListBox, а просто создал свою форму. Может кому пригодиться... Процедура формирования списка потоке: Код |
{ Опустошить StringGrid } procedure CleanGrid ( GrilleANettoyer : TStringGrid ); var x : integer; begin for x := 1 to GrilleANettoyer.RowCount - 1 do GrilleANettoyer.Rows[x].Clear;
GrilleANettoyer.RowCount := 2; GrilleANettoyer.FixedRows := 1; end;
{ Ссылка на текущий путь к FTP} function GetCurrentDirectory( MyHandle: HINTERNET ) : string; var LenS : Cardinal; S : string; begin LenS := 0; ftpGetCurrentDirectory( MyHandle, PChar(S), LenS ); SetLength(S, LenS); ftpGetCurrentDirectory( MyHandle, PChar(S), LenS ); Result := Trim(S); end;
{ Отображает текущую папку каталога ---------------------------------------------}
procedure FilesList( tStringGrid : TStringGrid; OnlyFolders,OnlyFiles:Boolean); var STRUCT_DATA : _WIN32_FIND_DATAA; FoundFile : Pointer; bFound : Boolean; BeFolder : boolean; FullSize : Integer;
begin BeFolder := False; FoundFile := nil; bFound := False; FullSize :=0; if PConnexionFTP <> nil then begin ProgressForm.ProgressStatus.Caption := INF_READ_DIR; MainPage.FTPselPath.Caption := GetCurrentDirectory( PConnexionFTP ); CleanGrid( tStringGrid );
tStringGrid.Cells[1, tStringGrid.RowCount-1] := '..'; tStringGrid.Cells[2, tStringGrid.RowCount-1] := '---d----'; tStringGrid.RowCount := tStringGrid.RowCount + 1;
FoundFile := FtpFindFirstFile( PConnexionFTP, PChar('*.*'), STRUCT_DATA, 0, 0 );
if FoundFile <> nil then repeat
if (Trim(STRUCT_DATA.cFileName) <> '..') and (Trim(STRUCT_DATA.cFileName) <> '.') then begin
if (OnlyFolders = True) then if STRUCT_DATA.dwFileAttributes = 16 then // если OnlyFolders = true добавим в список только папки Begin // длинное или короткое имя ? if Trim(STRUCT_DATA.cFileName) <> '' then tStringGrid.Cells[1, tStringGrid.RowCount-1] := STRUCT_DATA.cFileName else tStringGrid.Cells[1, tStringGrid.RowCount-1] := STRUCT_DATA.cAlternateFileName; tStringGrid.Cells[2, tStringGrid.RowCount-1] := AttributeToStr( STRUCT_DATA.dwFileAttributes ); tStringGrid.Cells[3, tStringGrid.RowCount-1] := SizeToStr( STRUCT_DATA.nFileSizeLow ); tStringGrid.Cells[4, tStringGrid.RowCount-1] := DateTimeToStr( FileTimeToDateTime( STRUCT_DATA.ftLastWriteTime ) ); tStringGrid.RowCount := tStringGrid.RowCount + 1; end;
if (OnlyFolders = False) and (OnlyFiles = false)then // если OnlyFolders = false добавим в список файлы и папки Begin // длинное или короткое имя ? if Trim(STRUCT_DATA.cFileName) <> '' then tStringGrid.Cells[1, tStringGrid.RowCount-1] := STRUCT_DATA.cFileName else tStringGrid.Cells[1, tStringGrid.RowCount-1] := STRUCT_DATA.cAlternateFileName; tStringGrid.Cells[2, tStringGrid.RowCount-1] := AttributeToStr( STRUCT_DATA.dwFileAttributes ); tStringGrid.Cells[3, tStringGrid.RowCount-1] := FloatToStr( STRUCT_DATA.nFileSizeLow ); FullSize := FullSize + STRUCT_DATA.nFileSizeLow; tStringGrid.Cells[4, tStringGrid.RowCount-1] := DateTimeToStr( FileTimeToDateTime( STRUCT_DATA.ftLastWriteTime ) ); tStringGrid.RowCount := tStringGrid.RowCount + 1; End;
if (OnlyFiles = true)then if STRUCT_DATA.dwFileAttributes <> 16 then // если OnlyFiles = true добавим в список только файлы! Begin // длинное или короткое имя ? if Trim(STRUCT_DATA.cFileName) <> '' then tStringGrid.Cells[1, tStringGrid.RowCount-1] := STRUCT_DATA.cFileName else tStringGrid.Cells[1, tStringGrid.RowCount-1] := STRUCT_DATA.cAlternateFileName; tStringGrid.Cells[2, tStringGrid.RowCount-1] := AttributeToStr( STRUCT_DATA.dwFileAttributes ); tStringGrid.Cells[3, tStringGrid.RowCount-1] := FloatToStr( STRUCT_DATA.nFileSizeLow ); FullSize := FullSize + STRUCT_DATA.nFileSizeLow; tStringGrid.Cells[4, tStringGrid.RowCount-1] := DateTimeToStr( FileTimeToDateTime( STRUCT_DATA.ftLastWriteTime ) ); tStringGrid.RowCount := tStringGrid.RowCount + 1; End; end; bFound := InternetFindNextFile( FoundFile, @STRUCT_DATA ); if KillTread = true then Begin // т.к. прервали уйдем на директорию ниже которую запомнили // в переменной пути EnterToDirectory('/'+MainPage.FTPselPath.Caption); break; end; until not bFound;
InternetCloseHandle( FoundFile ); tStringGrid.Cells[3, 1] := FloatToStr(FullSize ); end; end;
{ Открывает каталог } procedure EnterToDirectory( Directory : string ); var CurrentPath : string; Temp : string; bSuccess : LongBool; begin ProgressForm.ProgressStatus.Caption := INF_OPEN_DIR; CurrentPath := GetCurrentDirectory( PConnexionFTP ); if (Trim(CurrentPath) = Trim('/'+Directory)) then Begin Directory :=''; End;
if (Directory = '..') then Temp := ExtractBeforeFolder( CurrentPath ) else Begin Temp := SlachFTP(CurrentPath) + Directory; End;
if (LeftStr(Directory,1)='/') then Begin temp := Directory; End; // заполним адресную строку в форме выбора папок SelectForm.FTPFolders.Cells[1,0]:=Copy(' Текущий путь: /',1,15)+temp; bSuccess := FtpSetCurrentDirectory(PConnexionFTP, PChar(Temp));
if IsConnected = true then Begin if not bSuccess then begin MessageBoxA( HandleMain, PChar( 'Не найден указанный путь '+#13+Temp+#13+' на FTP сервере: '+MainPage.EditFTP.text), PChar('Ошибка'), 32 ); Exit; end; End else Begin MessageBoxA(HandleMain, PChar('Подключитесь перед использованием этой функции !'), PChar('Подключение ?'), MB_ICONEXCLAMATION); Exit; End;
end;
procedure TOpenFTPFolderThread.Execute; var Directory : string; begin
inherited; if MainPage.IsFolder(SelectForm.FTPFolders) = False then begin MessageBoxA( Self.Handle, PChar('Можно открыть только папку'), PChar('Ошибка'), 32); Exit; end;
Directory := Grid.Cells[1, Grid.selection.Top]; // если запускаем при старте формы, значит указываем путь if path <> '' then begin Directory := path; end; EnterToDirectory(Directory); FilesList(Grid, True,false);
// закрываем окно SendMessage(Progress.ProgressForm.Handle, WM_CLOSE, SW_HIDE, sw_ParentClosing);
end;
|
Форма выбора папок: Код | unit SelFolder;
interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, Grids, Outline, DirOutln, ExtCtrls, ImgList;
type TSelectForm = class(TForm) FTPFolders: TStringGrid; BitBtnShowFolders: TBitBtn; Ok: TBitBtn; ImageList1: TImageList; Label1: TLabel; Panel1: TPanel; Cencel: TBitBtn; procedure BitBtnShowFoldersClick(Sender: TObject); procedure FTPFoldersDblClick(Sender: TObject); procedure FTPFoldersDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); procedure OkClick(Sender: TObject); procedure FormResize(Sender: TObject); procedure CencelClick(Sender: TObject); procedure FormShow(Sender: TObject); private { Private declarations } procedure OpenFTPFolder1Click(Sender: TObject; Path:string); Public {declarations } SelectedFTPFolder:string; end;
var SelectForm: TSelectForm;
implementation uses main,FTP,module,ComObj, ActiveX, ShellApi,ShlObj,Progress; {$R *.dfm}
type TIconType = (itSmall, itLarge); { Отображает папки на FTP} procedure TSelectForm.BitBtnShowFoldersClick(Sender: TObject); begin // запустить подключение в отдельном поток и отображать индикатор ожидания Try ProgressForm := TProgressForm.create(nil); // создать форму индикатор GetFoldersThread:=TGetFoldersThread.Create(false); GetFoldersThread.ProgressForm := ProgressForm.Handle; GetFoldersThread.Resume; ProgressForm.ShowModal(); // показываем модально форму индикатор if GetFoldersThread.Terminated = true then // если поток завершен ProgressForm.Free; //очищаем указатель на форму с прогрессом Finally End;
Begin SelectForm.Close; end; end;
{Открывает папку на FTP} procedure TSelectForm.OpenFTPFolder1Click(Sender: TObject;path:string); begin Try ProgressForm := TProgressForm.create(nil); // создать форму индикатор OpenFTPFolderThread:=TOpenFTPFolderThread.Create(FTPFolders,''); OpenFTPFolderThread.ProgressForm := ProgressForm.Handle; OpenFTPFolderThread.Resume; ProgressForm.ShowModal(); // показываем модально форму индикатор if OpenFTPFolderThread.Terminated = true then // если поток завершен ProgressForm.Free; //очищаем указатель на форму с прогрессом Finally End; end;
{Устанавливает выбранную папку в путь} procedure TSelectForm.OkClick(Sender: TObject); Var SelectedPath:String; begin SelectedPath := FTPFolders.Cells[1, FTPFolders.selection.Top];
if (SelectedPath = '..') or (SelectedPath = '') then Begin SelectedPath := (FTPFolders.Cells[1,0]); SelectedPath :=Copy(SelectedPath,17,Length((SelectedPath))); SelectedFTPFolder := SelectedPath; end else Begin SelectedFTPFolder := SelectedPath; End; close; end;
{При двойном шелчке по таблице с папками} procedure TSelectForm.FTPFoldersDblClick(Sender: TObject); begin if ( Trim(FTPFolders.Cells[2, FTPFolders.selection.Top]) = '' ) then begin MessageBoxA( Self.Handle, PChar('Выберите правильный путь'), PChar('Ошибка'), 32); Exit; end; if MainPage.IsFolder(FTPFolders) then OpenFTPFolder1Click(self,'') else Begin ShowMessage('Это не папка!!!') end; end;
{Автоматический подгон по содержимому ширины столбца в таблице} procedure AutoSizeGridColumn(Grid: TStringGrid; column: integer); var i: integer; temp: integer; max: integer; begin max := 0; for i := 0 to (Grid.RowCount - 1) do begin temp := Grid.Canvas.TextWidth(grid.cells[column, i]); if temp > max then max := temp; end; Grid.ColWidths[column] :=max+ Grid.GridLineWidth + 3; end;
{При прорисовывании ячеек в таблице с папками} procedure TSelectForm.FTPFoldersDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); img:ticon; begin img := Ticon.Create; if (FTPFolders.Cells[1,ARow] <> '') and (FTPFolders.Cells[1,ARow] <> '..') then Begin ImageList1.GetIcon(3,img); End else begin ImageList1.GetIcon(0,img) ; end; // условие, определяющее нужную ячейку if ((ACol = 0) and (ARow <> FTPFolders.RowCount-1))and (ARow<>0) then begin // назначение размера ячейки по ширине и высоте FTPFolders.ColWidths[ACol] := img.Width; FTPFolders.RowHeights[ARow] := img.Height; // вывод рисунка в текущей ячейке FTPFolders.Canvas.StretchDraw(Rect, img); FTPFolders.ColWidths[1]:=518; FTPFolders.ColWidths[2]:=0; FTPFolders.ColWidths[3]:=0; FTPFolders.ColWidths[4]:=0; end; end; end.
|
ProgressForm это просто форма ожидания с индикатором ... Это сообщение отредактировал(а) Nicholas - 28.9.2016, 08:58
|