[[nlsgarcia]]

javiparera,

Empezado por javiparera

...lo que hace el programa (Lazarus) es: descomprimir unas carpetas que están en formato ZIP...renombra los archivos que contienen las carpetas "descomprimidas"...copia los archivos renombrados...hace unos días comenzó a tirarme un cartel con el siguiente error : Access denied Press OK to ignore and risk data corruption Press CANCEL to kill the program...¿Me podrán dar una idea que puede ser lo que esté ocurriendo?...

Revisa este código:

Código Delphi [-]
unit Unit1;

{$mode objfpc}{$H+}

{$Optimization off}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, Zipper;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    Button7: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1 : TForm1;
  DirectorySource : String;
  DirectoryTarget : String = 'C:\TempFiles';
  FileZip : String = 'C:\TestZipFile.zip';

implementation

{$R *.lfm}

{ TForm1 }

// List of files to compress
function DirectoryList(const DirectorySource: String; var FileList : TStringList) : Boolean;
var
   SR: TSearchRec;

begin

   try
      if FindFirst(DirectorySource + '\*.*', faAnyFile, SR) = 0 then
      repeat
         if (SR.Attr and faDirectory = faDirectory) and (SR.Name <> '.') and (SR.Name <> '..') then
            DirectoryList(IncludeTrailingPathDelimiter(DirectorySource) + SR.Name, FileList);

         if (SR.Attr and faArchive = faArchive) then
            FileList.Add(Copy(DirectorySource,4,MaxInt) + '\' + SR.Name);
      until FindNext(SR) <> 0;

      FindClose(SR);

      Result := True;
   except
      Result := False;
   end;

end;

// Removes directories
function DeleteFolder(const DirectoryName : String) : Boolean;
begin

  try
     if DirectoryExists(DirectoryName) then
     begin
        DeleteDirectory(DirectoryName,True);
        RemoveDir(DirectoryName);
        Result := True;
     end
     else
        Result := False;
  except
     Result := False;
  end;


end;

// List of files to copy
procedure CopyList(DirSource, Search : String; Recursive : Boolean; var FileList : TStringList);
var
   SR : TSearchRec;
   FileName, FileExt : String;
   SearchName, SearchExt : String;

begin

   DirSource := IncludeTrailingPathDelimiter(DirSource);

   if (not DirectoryExists(DirSource)) then
      Exit;

   SearchName := Copy(Search, 1, Pos('.',Search)-1);
   SearchExt := Copy(ExtractFileExt(Search),2,MaxInt);

   if FindFirst(DirSource + '*.*', faAnyFile, SR) = 0 then
   repeat
      if ((SR.Attr and fadirectory) = fadirectory) then
      begin
         if(SR.Name <> '.') and (SR.Name <> '..') and Recursive then
            CopyList(DirSource + SR.Name, Search, Recursive, FileList);
      end
      else
      begin
         FileName := Copy(ExtractFileName(SR.Name), 1, Pos('.',ExtractFileName(SR.Name))-1);
         FileExt := Copy(ExtractFileExt(ExtractFileName(SR.Name)),2,MaxInt);

         if (SearchName = '*') and (SearchExt = '*') then
            FileList.Add(DirSource + SR.Name);

         if (SearchName = '*') and (SearchExt <> '*') then
            if LowerCase(FileExt) = LowerCase(SearchExt) then
               FileList.Add(DirSource + SR.Name);

         if (SearchName <> '*') and (SearchExt = '*') then
            if LowerCase(FileName) = LowerCase(SearchName) then
               FileList.Add(DirSource + SR.Name);
      end;
   until FindNext(SR) <> 0;

   FindClose(SR);

end;

// Copy files
function CopyFiles(Source, Target : String; Recursive : Boolean) : Boolean;
var
   Search : String;
   DirSource : String;
   FileList : TStringList;
   FileName : String;
   i : Integer;

begin
  try
     Search := ExtractFileName(Source);
     if Pos('*',Search) = 0 then
     begin
        CopyFile(Source, Target, [cffOverwriteFile, cffCreateDestDirectory]);
        Result := True;
        Exit;
     end
     else
     begin
        FileList := TStringList.Create;
        DirSource := IncludeTrailingPathDelimiter(ExtractFilePath(Source));
        CopyList(DirSource, Search, Recursive, FileList);
        for i := 0 to FileList.Count -1 do
        begin
           FileName := StringReplace(FileList.Strings[i],DirSource,'',[rfIgnoreCase]);
           CopyFile(FileList.Strings[i],
                    IncludeTrailingPathDelimiter(Target) + FileName,
                    [cffOverwriteFile, cffCreateDestDirectory]);
        end;
        Result := True;
        Exit;
     end;
  except
     Result := False;
  end;
end;

// Modo-1 Compress Files
procedure TForm1.Button1Click(Sender: TObject);
var
   Zipper : TZipper;
   FileList : TStringList;

begin

   if SelectDirectory('Select Directory to Compress', 'C:\', DirectorySource) then
   begin
      SetCurrentDir(ExtractFileDrive(DirectorySource)+'\');
      FileList := TStringList.Create;
      DirectoryList(DirectorySource, FileList);

      Zipper := TZipper.Create;
      Zipper.FileName := FileZip;
      Zipper.Entries.AddFileEntries(FileList);
      Zipper.ZipAllFiles;

      Zipper.Free;
      FileList.Free;

      MessageDlg('Compressed Directory',mtInformation,[mbOk],0);
   end
   else
      MessageDlg('Directory Selection Aborted',mtWarning,[mbOk],0);

end;

// Modo-1 Decompress Files
procedure TForm1.Button2Click(Sender: TObject);
var
   openDialog : TOpenDialog;
   UnZipper: TUnZipper;

begin

   openDialog := TOpenDialog.Create(self);
   openDialog.InitialDir := 'C:\';
   openDialog.Options := [ofFileMustExist];
   openDialog.Filter := 'FileZip to Decompress |*.zip';

   if openDialog.Execute then
   begin
      UnZipper := TUnZipper.Create;
      UnZipper.FileName := openDialog.FileName;
      UnZipper.OutputPath := DirectoryTarget;
      UnZipper.UnZipAllFiles;
      MessageDlg('Decompressed Directory',mtInformation,[mbOk],0);
   end
   else
      MessageDlg('FileZip Selection Aborted',mtWarning,[mbOk],0);

   openDialog.Free;
   UnZipper.Free;

end;

// Modo-2 Compress Files
procedure TForm1.Button3Click(Sender: TObject);
var
   Zipper : TZipper;
   FileEntries : TZipFileEntries;
   FileList : TStringList;
   i : Integer;

begin

   if SelectDirectory('Select Directory to Compress', 'C:\', DirectorySource) then
   begin
      FileList := TStringList.Create;
      DirectoryList(DirectorySource, FileList);

      Zipper := TZipper.Create;
      Zipper.FileName := FileZip;

      FileEntries := TZipFileEntries.Create(TZipFileEntry);

      for i := 0 to FileList.Count - 1 do
          FileEntries.AddFileEntry(IncludeTrailingPathDelimiter(ExtractFileDrive(DirectorySource))  + FileList.Strings[i], FileList.Strings[i]);

      Zipper.ZipFiles(FileEntries);

      Zipper.Free;
      FileList.Free;
      FileEntries.Free;
      MessageDlg('Compressed Directory',mtInformation,[mbOk],0);
   end
   else
      MessageDlg('Directory Selection Aborted',mtWarning,[mbOk],0);

end;

// Modo-2 Decompress Files
procedure TForm1.Button4Click(Sender: TObject);
var
   openDialog : TOpenDialog;
   UnZipper: TUnZipper;
   i : Integer;
   FileList : TStringList;

begin

   openDialog := TOpenDialog.Create(self);
   openDialog.InitialDir := 'C:\';
   openDialog.Options := [ofFileMustExist];
   openDialog.Filter := 'FileZip to Decompress |*.zip';

   FileList := TStringList.Create;

   if openDialog.Execute then
   begin
      UnZipper := TUnZipper.Create;
      UnZipper.FileName := openDialog.FileName;
      UnZipper.OutputPath := DirectoryTarget;
      UnZipper.Examine;

      for i := 0 to UnZipper.Entries.Count - 1 do
        FileList.Add(UnZipper.Entries.Entries[i].ArchiveFileName);

      UnZipper.UnZipFiles(FileList);

      MessageDlg('Decompressed Directory',mtInformation,[mbOk],0);
   end
   else
      MessageDlg('FileZip Selection Aborted',mtWarning,[mbOk],0);

   openDialog.Free;
   UnZipper.Free;
   FileList.Free;

end;

// Modo-3 Compress Files
procedure TForm1.Button5Click(Sender: TObject);
var
   openDialog : TOpenDialog;
   Zipper : TZipper;
   FileEntries : TZipFileEntries;
   i : Integer;
   FileName : String;

begin

   openDialog := TOpenDialog.Create(self);
   openDialog.InitialDir := 'C:\';
   openDialog.Options := [ofFileMustExist, ofAllowMultiSelect];
   openDialog.Filter := 'Files to Compress |*.*';

   if openDialog.Execute then
   begin

      Zipper := TZipper.Create;
      Zipper.FileName := FileZip;

      FileEntries := TZipFileEntries.Create(TZipFileEntry);

      for i := 0 to openDialog.Files.Count - 1 do
      begin
         FileName := Copy(openDialog.Files[i],4,MaxInt);
         FileEntries.AddFileEntry(IncludeTrailingPathDelimiter(ExtractFileDrive(openDialog.Files[i])) + FileName, FileName);
      end;

      Sleep(1000); // Previene mensaje de error de riesgo de corrupción de data según pruebas realizadas

      Zipper.ZipFiles(FileEntries);

      Zipper.Free;
      FileEntries.Free;

      MessageDlg('Compressed Files Selected',mtInformation,[mbOk],0);
   end
   else
      MessageDlg('Files Selection Aborted',mtWarning,[mbOk],0);

   openDialog.Free;

end;

// Delete directory
procedure TForm1.Button6Click(Sender: TObject);
begin
   if DeleteFolder(DirectoryTarget) then
      MessageDlg('Directory Removed',mtInformation,[mbok],0)
   else
      MessageDlg('Directory Not Removed',mtError,[mbok],0);
end;

// Copy files
procedure TForm1.Button7Click(Sender: TObject);
begin

  {

    Ejemplo de uso de la función CopyFiles :
  
    function CopyFiles(Source, Target : String; Recursive : Boolean) : Boolean;
  
    CopyFiles('C:\TempFiles\*.*', 'C:\ProcessFiles', True);
    CopyFiles('C:\TempFiles\*.*', 'C:\ProcessFiles', False);
    CopyFiles('C:\TempFiles\*.pdf', 'C:\ProcessFiles', True);
    CopyFiles('C:\TempFiles\*.pdf', 'C:\ProcessFiles', False);
    CopyFiles('C:\TempFiles\FileText.*', 'C:\ProcessFiles', True);
    CopyFiles('C:\TempFiles\FileText.*', 'C:\ProcessFiles', False);
    CopyFiles('C:\TempFiles\FileText.txt', 'C:\ProcessFiles\FileText.txt', False);
  
    Nota : El parámetro Recursive permite hacer copias recursivas dentro de un directorio.

  }

   if CopyFiles('C:\TempFiles\*.*', 'C:\TempProcessFiles', True) then
      MessageDlg('Files Copied',mtInformation,[mbok],0)
   else
      MessageDlg('Files Not Copied',mtError,[mbok],0);

end;

end.

El código anterior en Lazarus 1.4.0 FPC 2.6.4 sobre Windows 7 Professional x32, Implementa varias rutinas de compresión y descompresión de archivos, así como de borrado de directorios y copia de archivos sin la utilización de APIs de Windows, como se muestra en la siguiente imagen:



El código propuesto esta disponible en : Lazarus ZipFile.rar

Espero sea útil

Nelson