basearchiveclass4.pas

delphi中把数据输出为html excel等形式的控件

unit BaseArchiveClass4;

{$I QExport4VerCtrl.inc}

interface

uses
  ZipMcpt4, Classes, SysUtils, QExport4Types;
{$IFDEF VCL6}
{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}
type
  TBaseArchiveClass = class
  private
    FFileName: string;
    FTempPath: string;
    FZipArchive: TMiniZip;
    procedure SetFileName(const Value: string);
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure Compress;
    procedure DeleteTempFolder;

    property FileName: string read FFileName write SetFileName;
    property TempPath: string read FTempPath write FTempPath;
  end;

implementation

uses
  {$IFDEF TEST_QE4ZIPCOMPRESS}
  zip4,
  {$ENDIF}
  QExport4StrIDs, QExport4{$IFDEF VER130}, FileCtrl{$ENDIF}{$IFDEF MSWINDOWS}, Windows{$ENDIF};

{ TBaseArchiveClass }

constructor TBaseArchiveClass.Create;
begin
  TempPath := ExtractFileDir(ParamStr(0)) + '\temp';
end;

destructor TBaseArchiveClass.Destroy;
begin

  inherited;
end;

procedure TBaseArchiveClass.SetFileName(const Value: string);
begin
  if FFileName <> Value then
    FFileName := Value;
end;

{$IFDEF VCL6}
{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}

procedure TBaseArchiveClass.DeleteTempFolder;

  function FullRemoveDir(Dir: string; DeleteAllFilesAndFolders,
    StopIfNotAllDeleted, RemoveRoot: boolean): Boolean;
  var
    i: Integer;
    SRec: TSearchRec;
    FN: string;
  begin
    {$IFDEF VCL6} 
      {$WARN SYMBOL_PLATFORM OFF}
    {$ENDIF}
    Result := False;
    if not DirectoryExists(Dir) then
      exit;
    Result := True;
    // add slash, mask = all files and folders
    {$IFDEF VCL6}
    Dir := IncludeTrailingPathDelimiter(Dir);
    {$ELSE}
    Dir := IncludeTrailingBackslash(Dir);
    {$ENDIF}
    i := FindFirst(Dir + '*', faAnyFile, SRec);
    try
      while i = 0 do
      begin
        // full path file or folder
        FN := Dir + SRec.Name;
        // if folder
        if (SRec.Attr and faDirectory) <> 0 then
        begin
          // Recursive call this functions with key of the removing root
          if (SRec.Name <> '') and (SRec.Name <> '.') and (SRec.Name <> '..') then
          begin
            if DeleteAllFilesAndFolders then
              FileSetAttr(FN, faArchive);
            Result := FullRemoveDir(FN, DeleteAllFilesAndFolders,
              StopIfNotAllDeleted, True);
            if not Result and StopIfNotAllDeleted then
              exit;
          end;
        end
        else // delete file
        begin
          if DeleteAllFilesAndFolders then
            FileSetAttr(FN, faArchive);
          Result := SysUtils.DeleteFile(FN);
          if not Result and StopIfNotAllDeleted then
            exit;
        end;
        // get next file or folder
        i := FindNext(SRec);
      end;
    finally
      SysUtils.FindClose(SRec);
    end;
    if not Result then
      exit;
    if RemoveRoot then // delete root if need
      if not RemoveDir(Dir) then
        Result := false;
    {$IFDEF VCL6}
      {$WARN SYMBOL_PLATFORM ON}
    {$ENDIF}
  end;

begin
  FullRemoveDir(TempPath, True, False, True);
end;

//{$DEFINE TEST_QE4ZIPCOMPRESS}

procedure TBaseArchiveClass.Compress;
{$IFDEF TEST_QE4ZIPCOMPRESS}
var
  err_log: TStrings;
  FS: TFileStream;
  Dir: string;
{$ENDIF}
  procedure RecurseAdd(ExtDir, CurrDir: string);
  var
    i, j: Integer;
    SRec: TSearchRec;
    FN: string;
    EndDir: string;
    {$IFDEF TEST_QE4ZIPCOMPRESS}
    err_no : Integer;
    {$ENDIF}
  begin
  {$IFDEF VCL6}
    {$WARN SYMBOL_PLATFORM OFF}
  {$ENDIF}
    if not DirectoryExists(CurrDir) then
      Exit;
    // add slash, mask = all files and folders
    {$IFDEF VCL6}
    CurrDir := IncludeTrailingPathDelimiter(CurrDir);
    {$ELSE}
    CurrDir := IncludeTrailingBackslash(CurrDir);
    {$ENDIF}
    i := FindFirst(CurrDir + '*', faAnyFile, SRec);
    {$IFDEF TEST_QE4ZIPCOMPRESS}
    err_log.Add('');
    err_log.Add('CurrDir + "*" = '+ CurrDir + '*');
    {$ENDIF}
    try
      while i = 0 do
      begin
        // full path file or folder
        FN := CurrDir + SRec.Name;
        {$IFDEF TEST_QE4ZIPCOMPRESS}
        err_log.Add('  SRec.Name = ' + SRec.Name);
        err_log.Add('  SRec.Attr = ' + IntToStr(SRec.Attr));
        err_log.Add('  FN = ' + FN);
        err_log.Add('  ExtDir = ' + ExtDir);
        {$ENDIF}
        // if folder
        if (SRec.Attr and faDirectory) <> 0 then
        begin
          if (SRec.Name <> '') and (SRec.Name <> '.') and (SRec.Name <> '..') then
            RecurseAdd(ExtDir, FN);
        end
        else
        begin
          EndDir := Copy(FN, length(ExtDir) + 2, length(FN) - length(ExtDir) - 1);
          while (true) do
          begin
            j := Pos('\', EndDir);
            if (j > 0) then
              EndDir[j] := '/'
            else
              break;
          end;
          {$IFNDEF TEST_QE4ZIPCOMPRESS}
          FZipArchive.AddToZipFile( AnsiString(FN), AnsiString(EndDir));
          {$ELSE}
          err_no := FZipArchive.AddToZipFile( AnsiString(FN), AnsiString(EndDir));
          err_log.Add('    err_no = ' + IntToStr(err_no));
          err_log.Add('    EndDir = '+ EndDir);
          {$ENDIF}
        end;
        // get next file or folder
        i := FindNext(SRec);
      end;
    finally
      SysUtils.FindClose(SRec);
    end;
  {$IFDEF VCL6}
    {$WARN SYMBOL_PLATFORM ON}
  {$ENDIF}
  end;

{$IFNDEF TEST_QE4ZIPCOMPRESS}
var
  FS: TFileStream;
  Dir: string;
{$ENDIF}
begin
  Dir := ExtractFileDir(FileName);
  if Dir = EmptyStr then Dir := ExtractFilePath(ParamStr(0));
  if not DirectoryExists(Dir) then begin
    ForceDirectories(Dir);
    if not DirectoryExists(Dir) then
      raise Exception.CreateFmt({$IFDEF WIN32}QExportLoadStr(QEM_DirNotFound){$ENDIF}
                                {$IFDEF LINUX}QEM_DirNotFound{$ENDIF}, [Dir]);
  end;

  FS := TFileStream.Create(FileName, fmCreate);
  try
  finally
    FS.Free;
  end;

  try
    {$IFDEF TEST_QE4ZIPCOMPRESS}
    err_log := TStringList.Create();
    {$ENDIF}
    FZipArchive := TMiniZip.Create(nil);
    FZipArchive.Zipfile := AnsiString(FileName);
    RecurseAdd(TempPath, TempPath);
  finally
    FZipArchive.Free;
    DeleteTempFolder;
    {$IFDEF TEST_QE4ZIPCOMPRESS}
    err_log.SaveToFile(FileName+'.zip_log2');
    err_log.Free;
    {$ENDIF}
  end;
end;

end.