Форум программистов [Powered by Invision Power Board]

Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате

Форум программистов > Delphi: Общие вопросы > Список файлов на всех дисках компа

Автор: Dr Smth 19.11.2004, 14:14

Помогите! Нужно составить список путей ко всем файлам данного расширения на компе (например, в текстовом файле).

Для этого нужно программно узнать количество дисков, их названия. И искать файлы, причём во всех существующих папках!

Тут всего слишком много, чтобы мне сразу понять. К тому же, чего-то в толк не возьму, как пользоваться процедурой FindNext?

Есть какие-нибудь соображения (слёзно умоляя)?

Автор: Pakshin A. S. 19.11.2004, 15:34

Щас напишу... smile

Автор: Alex 19.11.2004, 15:43

Код


procedure GetAllFilesOnHdds(lst: TStrings);
  procedure ScanDir(Dir:string);
  // Поиск файлов
  var
    SearchRec:TSearchRec;
  begin
    if Dir<>'' then if Dir[length(Dir)]<>'\' then Dir:=Dir+'\';
    if FindFirst(Dir+'*.*', faAnyFile, SearchRec)=0 then repeat
      if (SearchRec.name='.') or (SearchRec.name='..') then Continue;
      if (SearchRec.Attr and faDirectory) <> 0 then
        ScanDir(Dir+SearchRec.name)
      else
        lst.Add(Dir+SearchRec.name);
    until FindNext(SearchRec)<>0;
    FindClose(SearchRec);
  end;

var
  Drive: Char; // Буква диска
  n: Integer;
const
  pref = ':\';
begin
  lst.Clear;
  lst.BeginUpdate;
  with TStringList.Create do try
    for Drive:= 'A' to 'Z' do
      if GetDriveType(PChar(Drive + pref)) = DRIVE_FIXED then
        Add(Drive + pref);
    for n:= 0 to count-1 do
      ScanDir(Strings[n]);
  finally
    lst.EndUpdate;
    Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GetAllFilesOnHdds(ListBox1.Items);
end;

Автор: Pakshin A. S. 19.11.2004, 15:53

Вот:

Код


procedure SaveFiles(filename:string; mask:string);
var
 drive:char;
 procedure FindF(dir:string);
 var
  f:text;
  function GetDirName(Dir: string):string;
  begin
  Result:=Dir;
  if Dir[Length(Dir)] <> '\'
   then
    Result:=Dir + '\'
  end;
  procedure FindFiles(Dir:string);
  var
   FSR, DSR:TSearchRec;
   Res:integer;
   function IsDirNotation(ADirName:string):boolean;
   begin
    Result:=(ADirName = '.') or (ADirName = '..')
   end;
  begin
   Dir:=GetDirName(Dir);
   Res:=FindFirst(Dir + Mask, faAnyFile, FSR);
   while Res = 0 do
    begin
     write(f, LowerCase(Dir + FSR.Name));
     Res:=FindNext(FSR)
    end;
   FindClose(FSR);
   Res:=FindFirst(Dir + '*.*', faDirectory, DSR);
   while Res = 0 do
    begin
     if ((DSR.Attr and faDirectory) = faDirectory) and not IsDirNotation(Dir + DSR.Name)
      then
       FindFiles(Dir + DSR.Name);
     Res:=FindNext(DSR)
    end;
   FindClose(DSR)
  end;
 begin
  AssignFile(f, filename);
  rewrite(f);
  FindFiles(dir);
  CloseFile(f)
 end;
begin
 for drive:='a' to 'z' do
  if GetDriveType(PChar(drive + ':\')) = DRIVE_FIXED
   then
    FindF(drive + ':\')
end;

Добавлено @ 15:53
smile

не поспел..

Автор: Dr Smth 21.11.2004, 16:21

Что-то не выходит.
Первый код выдаёт только список файлов в корне последнего диска.
Второй работает, но в файле получается какая-то абракадабра, к тому же, похоже виснет.

Автор: Alex 21.11.2004, 16:59

Dr Smth Качаем пример и убеждаемся, что все работает

Автор: Pakshin A. S. 21.11.2004, 17:51

Цитата(Dr @ 21.11.2004, 17:21)

абракадабра

Кодировка похоже... А насчет виснет: просто много файликов и дирректорий... smile

Автор: Dr Smth 22.11.2004, 13:28

Да нет. С кодировкой всё нормально. И пути выводятся. Только всё в обну строку, между путями куча точек, в общем, всё как-то в одном комке...
Добавлено @ 13:30

Цитата(Alex @ 21.11.2004, 16:59)

Качаем пример

Спасибо, скачал.
Сегодня ещё раз попробую.

Автор: Dr Smth 22.11.2004, 21:51

Alex, всё по прежнему.
Список всех файлов процедура делает. Причём довольно быстро.
Однако если заменить в строке

Код

if FindFirst(Dir+'*.*', faAnyFile, SearchRec)=0 then repeat

маску на ту, которая, собственно нужна, то она даёт только файлы, лежащие в корнях всех дисков, после чего вылетает из цикла. Например, я попробовал поискать INI-файлы. Получил только два (на разных дисках - в корне). Маловато для целой системы. Чего-то надо поправить.

Автор: Pakshin A. S. 22.11.2004, 21:55

Надо разделять поиск файлов и подкаталогов... посмотри на мой пример....
Добавлено @ 21:57

Код


 procedure ScanDir(Dir:string);
 // Поиск файлов
 var
   SearchRec:TSearchRec;
 begin
   if Dir<>'' then if Dir[length(Dir)]<>'\' then Dir:=Dir+'\';
   if FindFirst(Dir+'*.*', faAnyFile, SearchRec)=0 then 
    repeat
     if (SearchRec.name='.') or (SearchRec.name='..') then Continue;
     if (SearchRec.Attr and faDirectory) <> 0 then
       ScanDir(Dir+SearchRec.name)
     else
       if ExtractFileExt(Dir + SearchRec.Name) = '.ini'
        then
         lst.Add(Dir+SearchRec.name);
   until FindNext(SearchRec)<>0;
   FindClose(SearchRec);
 end;

Вот, доделал...

Автор: Dr Smth 24.11.2004, 13:41

Нет, что-то не выходит каменный цветок. Теперь показывает только один файл.

Автор: Pakshin A. S. 24.11.2004, 19:38

Нее.... ну это что-то не то определённо.......

Автор: Pakshin A. S. 24.11.2004, 19:59

Лови (усё проверено...):

Код


procedure FindF(dir:string; mask:string);
var
 FSR: TSearchRec;
 FRes: integer;
begin
 if dir[Length(dir)] <> '\'
  then
   dir:=dir + '\';
 FRes:=FindFirst(dir + '*.*', faAnyFile, FSR);
 while FRes = 0 do
  begin
   if ((FSR.Attr and faDirectory) = faDirectory) and (FSR.Name <> '.') and (FSR.Name <> '..')
    then
     FindF(dir + FSR.Name, mask)
    else
     if ExtractFileExt(FSR.Name) = mask
      then
       begin
        Form1.RichEdit1.Lines.Add(Dir + FSR.Name);
        Application.ProcessMessages
       end;
   FRes:=FindNext(FSR)
  end;
 FindClose(FSR)
end;

procedure FindFiles(mask:string);
var
 c:char;
begin
 for c:='a' to 'z' do
  if GetDriveType(PChar(c + ':\')) = DRIVE_FIXED
  then
   FindF(c + ':\', mask)
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 RichEdit1.Lines.Text:='';
 FindFiles('.ini');
end;

Добавлено @ 20:00
Хотя разница минимальна...
Добавлено @ 20:00
И то, не существенная... на первый взгляд...

Автор: Балбес 25.11.2004, 22:45

Пакшин Андрей Сергеевич хоть Dr Smth не ответил Вам, но я только что проверил, код работает на ура! smile

И это очень здорово, как раз то что мне нужно. Я рад до ушей. smile

Автор: Pakshin A. S. 25.11.2004, 22:50

Ещё бы не работало... smile

Автор: Dr Smth 1.12.2004, 19:47

Красота!
Жаль, что ProgressBar нельзя присобачить (т.к. число файлов заранее не известно).