Error de Access denied en aplicación de Descompresión de Archivos en Lazarus

[[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

[javiparera]

Hola Nelson... Muchas gracias por tu aporte. Voy a probar con este codigo que me pasas y luego les comento..
Saludos.. y muchas gracias

[javiparera]

Hola Nelson..como estas? antes que nada...muchas gracias por tu aporte, estuve probando los módulos y funcionan de maravilla.
Quería consultarte una cosa mas... viste que el programa crea un directorio "Carpeta Zip", pero luego cuando quiere remover el directorio, solo elimina los archivos que están dentro. Uno podría poner una condición que si el directorio no existe entonces lo cree, y listo... pero el tema está en lo siguiente:
cuando el programa descomprime, lo hace dentro del directorio "C:\Carpeta Zip" quedando así "C:\Carpeta Zip\tmp" mas los archivos dentro de la carpeta tmp.
Cuando remueve, lo que hace es eliminar solamente los archivos de la carpeta tmp, quedando el directorio "C:\Carpeta Zip\tmp" vacío.
Lo que necesito hacer de alguna manera, es eliminar TODO, osea, la carpeta Zip y todo su contenido...
¿existe alguna forma de hacer eso?
Desde ya muchas gracias

[[nlsgarcia]]

javiparera,

Empezado por javiparera

...necesito hacer de alguna manera, es eliminar TODO, osea, la carpeta Zip y todo su contenido...¿existe alguna forma de hacer eso?...

La función DeleteFolder del código propuesto en el Msg #5, borra recursivamente todo el contenido de una carpeta y la carpeta en si misma.

Adicionalmente te sugiero probar la función CopyFiles, esta junto a DeleteFolder son implementadas sin la utilización de APIs de Windows lo que facilita la portabilidad del código.

Espero sea útil

Nelson.

[javiparera]

Pero estoy utilizando la función "DeleteFolder" que me propusiste pero no me está funcionando...el resto funciona re bien pero esta función en particular borra todo lo que sea archivos, pero las carpetas las deja.

[[nlsgarcia]]

javiparera,

Empezado por javiparera

...estoy utilizando la función "DeleteFolder" que me propusiste pero no me está funcionando...borra todo lo que sea archivos, pero las carpetas las deja...

Te comento:

1- La función DeleteFolder, borra recursivamente todo el contenido de una carpeta y la carpeta en si misma.

2- Si la carpeta actual es la carpeta a borrar, DeleteFolder borrara todo su contenido (Archivos y carpetas) recursivamente pero no la carpeta actual en si misma.

Espero sea útil

Nelson.

[javiparera]

Entiendo el funcionamiento de la función DeleteFolder...lo que no entiendo es a que te referís con "la carpeta actual". Lo que hago en sí es crear una carpeta auxiliar donde se descompriman los archivos, se renombren y desde ahí se copien a otra carpeta...
Veamoslo de esta forma...
creo una carpeta parcial, realizo todas las operaciones y luego cuando esta todo listo, copio en la carpeta Final... luego quiero que la carpeta pacial, desaparezca...
¿como podría hacerlo?