この発言に対し以下のコメントが寄せられています

#00642　十兵衛          さん　RE:Directoryのコピー




みなさん、こんにちは。

NT351ではWindows95やNT4.0で使うことのできる「SHFileOperation」が使えない
のでフォルダ（ディレクトリ）まとめてのコピーが出来ません。
そこで作ったのが以下の関数です。

皆さんの添削をお待ちしております(^^)



//ディレクトリをディレクトリ配下にコピーする
//FromDir=コピー元のディレクトリ
//ToDir=コピー先のディレクトリ
//Loop=サブディレクトリがある場合 True =サブディレクトリもコピーする
//                                False=サブディレクトリはコピーしない
function CopyDirectory(FromDir,ToDir:TFileName;Loop:Boolean):Boolean;
var
 FDir,TDir,NewDir,SearchPath:TFileName;
 FromFileName,ToFileName:TFileName;
 FAttr:Integer;
 FSearchRec:TSearchRec;
 FHandle:THandle;
begin
 Result := False;
 if FromDir[Length(FromDir)] = '\' then SearchPath := FromDir
 else SearchPath := FromDir + '\';
 FDir := '\'+ExtractFileName(FromDir);
 if ToDir[Length(ToDir)] = '\' then TDir := Copy(ToDir,1,Length(ToDir)-1)
 else TDir := ToDir;
 NewDir := TDir+FDir;
 if NewDir[Length(NewDir)] <> '\' then NewDir := NewDir + '\';
 if not DirectoryExists(NewDir) then
 begin
  Result := CreateDir(NewDir);
  if not Result then Exit;
 end;
 FAttr := faReadOnly or faHidden or faSysFile
       or faDirectory or faArchive or faAnyFile;
 FHandle := FindFirst(PChar(SearchPath+'*.*'),FAttr,FSearchRec);
 try
  if FHandle = 0 then
  begin
   repeat
    if (FSearchRec.Attr and faDirectory) > 0 then
    begin
     if (FSearchRec.Name[1] <> '.') and Loop then
     begin
      Result := CopyDirectory(SearchPath+FSearchRec.Name,NewDir,Loop);
      if not Result then Exit;
     end;
    end else
    begin
     FromFileName := SearchPath+FSearchRec.Name;
     ToFileName := NewDir+FSearchRec.Name;
     Result := CopyFile(PChar(FromFileName),PChar(ToFileName),False);
     if not Result then Exit;
    end;
    Application.ProcessMessages;
    FHandle := FindNext(FSearchRec);
   until  FHandle <> 0;
  end;
 finally
  SysUtils.FindClose(FSearchRec);
 end;
end;

{使用例:選択されたディレクトリをD:\Temp配下にコピーします}
procedure TForm1.Button1Click(Sender: TObject);
var
 FDir:string;
 Ret:Boolean;
begin
 FDir := Copy(Application.ExeName,1,3);
 if SelectDirectory(FDir,[],-1) then
 begin
  Screen.Cursor := crHourGlass;
  try
   Ret := CopyDirectory(FDir,'D:\Temp',True);
  finally
   Screen.Cursor := crDefault;
   if Ret then ShowMessage('成功') else ShowMessage('失敗');
  end;
 end;
end;


                                     98/06/07(日) 23:56 十兵衛(BZT01311)

Original document by 十兵衛          氏 ID:(BZT01311)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。