Форум: "Начинающим";
Текущий архив: 2011.07.24;
Скачать: [xml.tar.bz2];

Вниз

Копирование файла по маске   Найти похожие ветки 

← →
Xalexo   (2011-04-07 22:08) [0]

Хотелось бы заставить работать следующую функцию так, чтобы в результирующий каталог копировались бы все файлы по маске, с сохранением исходной иерархии папок, т.е:
файл : "I:\D1\D2\D3\example.txt" должен быть скопирован как - "MY DRIVE:\D1\D2\D3\example.txt".
Помимаю, что нужно изменить всего лишь минимум кода стандартной процедуры, добавив 1,2 переменных, но вот где,и как ? Замучился,подскажите пожалуйста..

procedure scanproj(prdr,copytodir,drc : string);
var src : tsearchrec;
    i,lc : integer; preddrc,s:string;
begin
prdr:= includetrailingbackslash(prdr);
copytodir:=
includetrailingbackslash(copytodir);
with form1 do
 if directoryexists(prdr) then begin
    lc  := 0;

    try
      if findfirst(PrDr+"*.*",faAnyFile,SRC) = 0 then
         repeat
           inc(LC);
           if (src.name <> ".") and (src.name <> "..") then

              if     ((SRC.Attr and faDirectory) <> 0) then
              begin
                 drc:= src.name;{?}
                 scanproj(prdr+src.name+"\",copytodir,drc);
              end
              else

              if not ((SRC.Attr and faVolumeID) <> 0) then
              begin
              if HaveBadExt(SRC.Name)then
              begin

                      s:= src.name;
                      copyfile(pchar(prdr+src.name),pchar(copytodir+drc+"\"+s),false);
              end;
              end;

           if (LC mod 10) = 0 then application.ProcessMessages;
         until
         findnext(SRC) <> 0;

    finally
      FindClose(SRC);
    end;
 end;
end;


---

← →
Virgo_Style ©   (2011-04-07 22:13) [1]

при рекурсивном вызове нужно передавать соответствующим образом измененный copytodir

ну и создать этот каталог не забыть

---

← →
Xalexo   (2011-04-07 22:18) [2]

> Virgo_Style ©   (07.04.11 22:13) [1]
> при рекурсивном вызове нужно передавать соответствующим
> образом измененный copytodir ну и создать этот каталог не
> забыть


Я все это понимаю.. :), но как? Можно пожалуйста примерчик...

---

← →
Игорь Шевченко ©   (2011-04-07 22:37) [3]

Сто лет назад когда-то делалось:

const
 UM_PROGRESS = WM_APP + 555;

type
 TShortZString = array[0..Pred(MAX_PATH)] of Char;

 TCopyFilter = function (const FileName: PChar): Boolean;

function Utils_DirectoryExists (Directory: PChar): Boolean;
var
 Attributes: DWORD;
begin
 Result := false;
 if (Directory = nil) or (Directory^ = #0) then
   Exit;
 Attributes := GetFileAttributesA (Directory);
 Result := (Attributes <> DWORD(-1)) and ((Attributes and 16) <> 0);
end;

function Utils_ForceDirectoryTree (Directory: PChar): Boolean;
var
 SubDir: PChar;
begin
 SubDir := StrRScan (Directory + 1, "\");
 while Assigned(SubDir) do
 begin
   if ((SubDir - Directory) > 2) or (SubDir[-1] <> ":") then
   begin
     SubDir^ := #0;
     if not Utils_DirectoryExists (Directory) then
       CreateDirectoryA (Directory, nil);
     SubDir^ := "\";
   end;
   Inc(SubDir);
   SubDir := StrScan (SubDir, "\");
 end;
 if not Utils_DirectoryExists (Directory) then
   CreateDirectoryA (Directory, nil);
 Result := Utils_DirectoryExists (Directory);
end;

function Utils_CopyFile (SourceFileName, DestFileName: PChar): Boolean;
var
 Attributes: DWORD;
begin
 Attributes := GetFileAttributesA (DestFileName);
 if Attributes <> DWORD(-1) then
   SetFileAttributesA (DestFileName, FILE_ATTRIBUTE_NORMAL);
 Result := CopyFileA (SourceFileName, DestFileName, false);
 if Result and (Attributes <> DWORD(-1)) then
   SetFileAttributesA (DestFileName, FILE_ATTRIBUTE_NORMAL);
end;

function Utils_CopyTreeEx (Wnd: HWND; hCancelObject: THandle;
 Source, Destination: PChar;
 Filter: TCopyFilter; DoCount: Boolean): Integer;
var
 SrcDir, PMask, P: PChar;
 OkToProceed: Boolean;
 DstPath, TempSrc: TShortZString;
 DstPlace: PChar;
 FindHandle: THandle;
 FindData: WIN32_FIND_DATAA;
 InnerCopyResult: Integer;
begin
 Result := 0;
 DstPlace := nil;
 SrcDir := Source;
 PMask := nil;
 OkToProceed := true;
 if Assigned(Source) then begin
   if Utils_DirectoryExists (Source) then
     OkToProceed := SetCurrentDirectoryA (SrcDir)
   else begin
     P := StrRScan (SrcDir, "\");
     PMask := P;
     if Assigned(P) then begin
       lstrcpynA (TempSrc, SrcDir, (P - SrcDir) + 1);
       P := CharNextA (P);
       if P^ = #0 then
         PMask := nil;
       OkToProceed := SetCurrentDirectoryA (TempSrc);
     end else
       PMask := SrcDir;
   end;
   if not OkToProceed then
     Exit;
 end;
 if not DoCount then begin
   OkToProceed := Utils_ForceDirectoryTree (Destination);
   if not OkToProceed then
     Exit;
   lstrcpyA (DstPath, Destination);
   Utils_PathAppend (DstPath, "", -1);
   DstPlace := @DstPath[lstrlenA(DstPath)];
 end;
 FindHandle := FindFirstFileA (PMask, FindData);
 if FindHandle <> INVALID_HANDLE_VALUE then begin
   SrcDir := "..";
   repeat
     if not DoCount then
       lstrcpyA (DstPlace, FindData.cFileName);
     if (FindData.dwFileAttributes and 16) = 0 then begin
       if not Assigned(Filter) or (not Filter (FindData.cFileName)) then
         if (DoCount) then
           Inc(Result)
         else
           OkToProceed := Utils_CopyFile (FindData.cFileName, DstPath);
       if Wnd <> 0 then
         SendMessageW (Wnd, UM_PROGRESS, 0, 0);
     end else if (lstrcmpA (FindData.cFileName, ".") <> 0) and
         (lstrcmpA (FindData.cFileName, SrcDir) <> 0) and
         SetCurrentDirectoryA (FindData.cFileName) then begin
       InnerCopyResult := Utils_CopyTreeEx (Wnd, hCancelObject, nil, DstPath,
         Filter, DoCount);
       if DoCount then
         Inc (Result, InnerCopyResult)
       else
         OkToProceed := InnerCopyResult <> 0;
       SetCurrentDirectoryA (SrcDir);
     end;
     if (hCancelObject <> 0) and
        (WaitForSingleObject (hCancelObject, 0) <> WAIT_TIMEOUT) then
       OkToProceed := false;
   until not (OkToProceed and FindNextFileA (FindHandle, FindData));
   Windows.FindClose (FindHandle);
 end;
 if not OkToProceed then
   Result := 0
 else if not DoCount then
   Result := 1;
end;

function Utils_CopyDirectoryTree (Source, Destination: PChar;
 Filter: TCopyFilter): Boolean;
begin
 Result := Utils_CopyTreeEx (0, 0, Source, Destination, Filter, false) = 0;
end;

---

← →
Xalexo   (2011-04-07 22:44) [4]

> Игорь Шевченко

Спасибо, обязательно попробую..

---

← →
Xalexo   (2011-04-07 22:59) [5]

>  Игорь Шевченко

Если не трудно дайте пожалуйста также реализацию процедуры
Utils_PathAppend (DstPath, "", -1);
Еще раз спасибо.

---

← →
Игорь Шевченко ©   (2011-04-07 23:27) [6]

Не трудно

function Utils_PathAppend (Destination, Source: PChar;
 DestBufSize: Integer): PChar;
var
 Size: Integer;
 DestP: PChar;
begin
 DestP := Destination;
 Size := DestBufSize;
 if not Assigned(Destination) or not Assigned(Source) then begin
   Result := nil;
   Exit;
 end;
 if Destination^ <> #0 then begin
   repeat
     DestP := CharNextA (DestP);
     if Size <> 0 then Dec(Size);
   until DestP^ = #0;
   if (DestP > Destination) and
      (CharPrevA (Destination, DestP)^ <> "\") then begin
     if Size < 2 then begin
       Result := nil;
       Exit;
     end;
     DestP^ := "\";
     DestP := CharNextA (DestP);
     Dec(Size);
   end;
 end;
 if Size < 1 then begin
   Result := nil;
   Exit;
 end;
 while (Source^ = " ") or (Source^ = "\") do
   Source := CharNextA (Source);
 lstrcpynA (DestP, Source, Size);
 while DestP > Destination do begin
   DestP := CharPrevA (Destination, DestP);
   if DestP^ <> " " then
     Break;
   DestP^ := #0;
 end;
 Result := Destination;
end;

Не надо к коду относиться серьезно, его можно заменить с заметными сокращениями вызовами функций из SysUtils

---

← →
Xalexo   (2011-04-07 23:48) [7]

Да, я уже понял, но для большей полноты понимания очень даже не помешает.. :)

---

← →
antonn ©   (2011-04-08 01:17) [8]

У меня подозрение что учетку Игоря взломали =)

---

← →
Германн ©   (2011-04-08 03:12) [9]

Удалено модератором

---

← →
Xalexo   (2011-04-22 07:35) [10]

:) Путем проб и ошибок наконец получил, что-то вразумительное...
Функция проходит по дереву папок исходного драйва и копирует файлы по заданной маске, вместе с предшествующими поддиректориями, т.е - по полному пути, в новое место, тем самым добиваясь перезаписи уже присутствующих файлов при следующим цикле.

procedure scanproj(prdr,copytodir:string);
var src : tsearchrec;
    i,lc : integer; s:string;
begin
prdr:=      includetrailingbackslash(prdr);
copytodir:= includetrailingbackslash(copytodir);
try
 with form1 do
 if directoryexists(prdr) then begin
    lc  := 0;
      if findfirst(PrDr+"*.*",faAnyFile,SRC) = 0 then
         repeat
           inc(LC);
           if (src.name <> ".") and (src.name <> "..") then

              if     ((SRC.Attr and faDirectory) <> 0) then
              begin
                 scanproj(prdr+src.name+"\",copytodir);
              end
              else

              if not ((SRC.Attr and faVolumeID) <> 0) then
              begin
              (*функция на проверку файла по предопред. маске*)
              if HaveBadExt(SRC.Name)then
              begin
                      (*т.к в данном случае копируется весь диск, для создания подпапки с тем же именем удаляется двоеточие*)
                      s:= prdr; delete(s,pos(":",s),1);
(*если новый путь не сущ. - форсим его*)                      
if not directoryexists(copytodir + s) then forcedirectories(copytodir + s);
(*и наконец копируем сам файл*)                      
copyfile(pchar(prdr+src.name),pchar(copytodir+s+src.name),false);
              end;
              end;

           (*для обратной связи с приложением*)
           if (LC mod 100) = 0 then application.ProcessMessages;
         until
         findnext(SRC) <> 0;
    end;
    finally
      FindClose(SRC);
    end;
end;

---

Страницы: 1 вся ветка

Форум: "Начинающим";
Текущий архив: 2011.07.24;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.5 MB
Время: 0.003 c