空フォルダの検出削除をする (ID:35238)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

よろしくお願いします。
winXP  Delphi６Personalです。
あるフォルダの下にある無数のフォルダ内のファイルをある条件で削除しますが、
階層にかかわらずその下にファイルがないなら削除したいのです。
下の考え方は、まず階層＋フォルダパス名のリストを作成する。
次にフォルダリストを階層でソートする。
次に階層の深い順にフォルダを取り出しファイルが一個でもないか調べる。
ただし、隠しファイルはあっても無視する。
ファイルがないとフォルダを削除する。

何とも見苦しいコードですが、もっとスマートな方法はないのでしょうか。
よろしくお願いします。

procedure TForm1.KaraFolderDel(Path: string);
var
    FolderList:TStringList;
		//*************フォルダを削除する***************
		procedure  DeleteRootin(FromFile:string);
		var
		    hSHFileOpStruct:  TSHFileOpStruct;
		begin
			with  hSHFileOpStruct do
			begin
			    wnd              := 0;
		        wFunc            := FO_DELETE;
			  pFrom              := PChar(FromFile + #0);
			  pTo                := nil;//同じだったら新しい名前を付ける                                                  //FileNameを非表示
		      fFlags             := FOF_NOCONFIRMMKDIR or FOF_NOCONFIRMATION;// or FOF_SIMPLEPROGRESS;   //上書きしない
		 	  fAnyOperationsAborted :=   False;
			  hNameMappings      := nil;
		      lpszProgressTitle  := nil;
			end;
		    SHFileOperation(hSHFileOpStruct);
		end;
		//*************フォルダリストを作成する***************
		procedure Build( Path: String; level:integer);
		var
		     SearchRec:TSearchRec;
		     level2:integer;
		     str:string;
		begin
		    Path :=  ExcludeTrailingPathDelimiter(Path);  //最後の¥をつける
		    if  (FindFirst(Path + '\*.*', faAnyFile, SearchRec) = 0) then
		    begin
		        try
		            repeat
		                if  ((SearchRec.Name <> '.') and (SearchRec.Name <> '..')) then
		                begin
		                    if  ((SearchRec.Attr and faDirectory) > 0)  then
		                    begin
		                        str:= Path + '\'+ SearchRec.Name;
		                        FolderList.Add(AnsiQuotedStr(IntToStr(Level), '"')+','+AnsiQuotedStr(str, '"'));
		                        level2:=level+1;
		                        Build(Path + '\'+ SearchRec.Name, level2)
		                    end;
		                end;
		            until (FindNext(SearchRec) <> 0);
		        finally
		            FindClose(SearchRec);
		        end;
		    end;
		end;
		//***********フォルダ内にフォルダかファイルの有無を調べる******************
		procedure FindFiles(Path:string; var DirList, FileList: integer);
		 var
		  SearchRec: TSearchRec;
		  Attr:integer;
		 begin
		  Attr:=(faReadOnly +faSysFile+faVolumeID+faDirectory+faArchive);
		  Path :=  ExcludeTrailingPathDelimiter(Path);
		    if  (FindFirst(Path + '\*.*', Attr, SearchRec) = 0) then
		    begin
		        try
		            repeat
		                if  ((SearchRec.Name <> '.') and (SearchRec.Name <> '..')) then
		                begin
		                    if  ((SearchRec.Attr and faDirectory) > 0)  then
		                      begin Inc(DirList);break;end
		                    else
		                      begin
		                      if SearchRec.Attr<>faHidden then
		                      begin Inc(FileList);break;end;
		                      end;
		                end;
		            until (FindNext(SearchRec) <> 0);
		        finally
		            FindClose(SearchRec);
		        end;
		    end;
		 end;
		 //******************************
var
  DirList,FileList:integer;
  i:integer;
  StrList:TStringList;
  FolderPath:string;
begin
    FolderList:=TStringList.Create;  //フォルダリストを作成する
    StrList:=TStringList.Create;
    try
       Build(Path,0);
       FolderList.Sorted:=true;//階層の深さでソートする
		//階層の深いフォルダ順にファイルがあるか調べて無ければ削除する
       for i:= FolderList.count-1 downto 0 do
       begin
           StrList.CommaText:=FolderList.Strings[i];
           FolderPath:= StrList.Strings[1];

DirList:=0; FileList:=0;
           FindFiles(FolderPath, DirList,FileList);
			//ファイルもフォルダもなければ削除する
           if  (DirList=0) and (FileList=0) then
           begin
            DeleteRootin( FolderPath);
           end;
       end;
    finally
        FolderList.Free;
        StrList.Free;
    end;

end;

←解決時は質問者本人がここをチェックしてください。

戻る