この発言は
#00642　十兵衛          さんのRE:Directoryのコピー
に対するコメントです



十兵衛 さん、こんにちは。十兵衛です。

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

不具合が発見されたので別方法で回避しましたが果たして正しい方法かどうか？
皆さんの添削をお待ちしております(^^)



//ディレクトリをディレクトリ配下にコピーする
//FromDir=コピー元のディレクトリ
//ToDir=コピー先のディレクトリ
//Loop=サブディレクトリがある場合 True =サブディレクトリもコピーする
//                                False=サブディレクトリはコピーしない
function CopyDirectory(FromDir,ToDir:TFileName;Loop:Boolean):Boolean;
var
 FromFileName,ToFileName:TFileName;
 FromFileList,ToFileList:TStringList;
 IDX:Integer;
 //内部関数開始
 function SetFromToFile(FromFileList,ToFileList:TStringList;
                        FromDir,ToDir:TFileName;Loop:Boolean):Boolean;
 var
  FDir,TDir,NewDir,SearchPath:TFileName;
  FAttr:Integer;
  FSearchRec:TSearchRec;
  FHandle:THandle;
 begin
  Result := True;
  //初期ディレクトリ操作
  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 + '\';
  //初期ディレクトリ操作（終了）
  FAttr := faReadOnly or faHidden or faSysFile
        or faDirectory or faArchive or faAnyFile;
  FHandle := FindFirst(PChar(SearchPath+'*.*'),FAttr,FSearchRec);
  try
   try
     if FHandle = 0 then begin
      repeat
       if (FSearchRec.Attr and faDirectory) > 0 then begin
          if (FSearchRec.Name[1] <> '.') and Loop then begin
             //ディレクトリも保存対象に
             FromFileList.Add(SearchPath+FSearchRec.Name+'\');
             ToFileList.Add(NewDir+FSearchRec.Name+'\');
             //再帰処理
             Result := SetFromToFile(FromFileList,ToFileList,
                         SearchPath+FSearchRec.Name,NewDir,Loop);
             if not Result then Exit;
          end;
       end else begin
          FromFileList.Add(SearchPath+FSearchRec.Name);
          ToFileList.Add(NewDir+FSearchRec.Name);
       end;
       Application.ProcessMessages;
       FHandle := FindNext(FSearchRec);
      until  FHandle <> 0;
     end;
   except
     Result := False;
   end;
  finally
    SysUtils.FindClose(FSearchRec);
  end;
 end;
 //内部関数終了
begin
 //コピー元・先ファイルの名の待避用List
 FromFileList := TStringList.Create;
 ToFileList := TStringList.Create;
 try
  //待避処理
  Result := SetFromToFile(FromFileList,ToFileList,FromDir,ToDir,Loop);
  if not Result then Exit;
  Result := FromFileList.Count = ToFileList.Count;
  if not Result then Exit;
  for IDX := 0 to FromFileList.Count-1 do begin
     FromFileName := FromFileList.Strings[IDX];
     ToFileName := ToFileList.Strings[IDX];
     if not DirectoryExists(ExtractFileDir(ToFileName)) then begin
        ForceDirectories(ExtractFileDir(ToFileName));
        Result := DirectoryExists(ExtractFileDir(ToFileName));
        if not Result then Exit;
     end;
     //'\'で終了しているのはディレクトリ
     if ToFileName[Length(ToFileName)] <> '\' then begin
      //同じファイルなら処理しない
       if AnsiCompareText(FromFileName,ToFileName) <> 0 then begin
          Result := 
             CopyFile(PChar(FromFileName),PChar(ToFileName),False);
          if not Result then Exit;
       end;
     end;
  end;
 finally
  FromFileList.Free;
  ToFileList.Free;
 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/09/01(火) 23:26 十兵衛(BZT01311)

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

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