Поиск папок

[Artificial]

Доброе время суток, надо сделать поиск всех папок на HDD, после чего вывести список.
Сделал поиск папок и их подпапок, но вот дальше не могу сделать.
Принцип такой, программа заходит в папку, смотрит есть ли в н ей папки, если есть то проверяет дальше и записывает, если нет возвращается назад.
Вот код:

program poisk;
uses crt, dos;
var

     s: string;
     f, f1, f2: text;
     c, i, o, k: integer;
     gid: searchrec;
     m: array[1..100] of string;
     d: array[1..100] of string;
  
procedure mass_sbor;
begin
i:=0;
Reset(f1);
while not EOF(f1) do
                 begin
                        inc(i);
                        readln(f1,d[i]);
                        end;
Close(f1);
for k:=1 to i-1 do begin
ChDir(d[k]);
FindFirst('*.*',anyfile,gid);
writeln(d[k]);
while DosError=0 do begin

Findnext(gid);
if (gid.name <> '.') or (gid.name <> '..') then begin
if gid.attr=16  then begin
                        Append(f2);
                        writeln(f2,d[k],gid.name,'/');
                        close(f2);
                        for o:=1 to high(d[k]) - 1 do begin
                                                        // continue programm
                                                  end;
end;
                    end;
                        end;
                        write('Complete..');
                        end;
end;
procedure sbor;
begin
i:=0;
Reset(f);
while not EOF(f) do
                 begin
                        inc(i);
                        readln(f,m[i]);
                        end;
Close(f);
for o:=1 to i-1 do begin
ChDir(m[o]);
FindFirst('*.*',anyfile,gid);

while DosError=0 do begin

Findnext(gid);
if gid.attr=16 then begin
                        Append(f1);
                        writeln(f1,m[o],'/',gid.name,'/');
                        close(f1);
                    end;
                    end;
                        end;
                        write('Complete..');
                        end;

begin
clrscr;

Assign(f,'C:/paths.txt');
Assign(f1,'C:/dirlist.txt');
Assign(f2,'C:/podkat.txt');
Rewrite(f);
Close(f);
Rewrite(f1);
Close(f1);
Rewrite(f2);
Close(f2);
write('Enter path: ');readln(s);
Chdir(s);
FindFirst('*.*',anyfile,gid);

while DosError=0 do begin
Findnext(gid);
if gid.attr=16  then begin

                        Append(f);
                        writeln(f,s +gid.name);
                        close(f);
                    end;
end;
sbor;
mass_sbor;
readln;
end.

В программе есть лишнее, на это внимание не обращать. Писалось очень быстро.)
Помогите, спасибо!
Сбор подкаталогов третьего уровня немного криво работает)

[alexBlack]

Используй рекурсию:

procedure findFolders(Path:String);
begin
    N := FindFirst(Path+'*.*',anyfile,gid); 
    while N = 0 do begin  
        if   // Здесь проверяем Если папка и не . и ..
            findFolders(Path+gid.Name+'\')
        end;
        FindNext(gid);
    end;
end;

findFolders('c:\');

[Artificial]

Хм, спасибо, попробуем.