unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function ExtractTar(SrcPath, DestPath: String; var AMsg: String): Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
type
  TTarFunc = function (const hWnd: HWND; szCmdLine: LPCSTR; szOutPut: LPSTR;
    constdwSize: DWORD): Integer; stdcall;


//=============================================================================
//  tar32.dllを使用した書庫ファイルの解凍のテスト
//  解凍先のディレクトリがない場合は自動作成して上書き保存
//
//  tar32.dllで扱える書庫の例
// -----------------------------------------------------
//  形式         定数名               定数値
// -----------------------------------------------------
//  TAR          ARCHIVETYPE_TAR      1
//  TAR.GZ(TGZ)  ARCHIVETYPE_TARGZ    2
//  TAR.Z(TAZ)   ARCHIVETYPE_TARZ     3       展開のみ
//  GZ(GZIP)     ARCHIVETYPE_GZ       4
//  Z            ARCHIVETYPE_Z        5       展開のみ
//  TAR.BZ2      ARCHIVETYPE_TARBZ2   6
//  BZ2          ARCHIVETYPE_BZ2      7
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  SrcFile   : String;
  DestDir   : String;
  ResultMsg : string;
  flgResult : Boolean;
begin
  //解凍対象の書庫ファイルを選択
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  OpenDialog1.Filter     := 'tar (TGZ,TAZ,BZ2) 書庫|*.tar.gz;*.tar.z;*.tar.bz2|' +
                            'tar 書庫|*.tar|' +
                            'gz (GZIP) 書庫|*.gz|' +
                            'z 書庫|*.z|' +
                            'bz2 (BZIP2) 書庫|*.bz2|';
  OpenDialog1.FileName   := '';
  if not OpenDialog1.Execute then exit;

  //SrcFileは解凍する対象のファイルのフルパス
  //DestDirは解凍したファイルを格納するディレクトリ名のフルパス
  SrcFile  := OpenDialog1.FileName;
  DestDir := ExtractFilePath(Application.ExeName)+ 'Temp';

  //解凍
  flgResult := ExtractTar(SrcFile, DestDir, ResultMsg);

  if flgResult then begin
    MessageBox(Handle, '解凍終了', '実行結果', MB_ICONINFORMATION);
  end else begin
    MessageBox(Handle, '解凍失敗', '実行結果', MB_ICONSTOP);
  end;
end;

//-----------------------------------------------------------------------------
//  tar32.dll内のTarという関数を使用して書庫を解凍する
//-----------------------------------------------------------------------------
function TForm1.ExtractTar(SrcPath, DestPath: String;
  var AMsg: String): Boolean;
const
  BUFF_SIZE = 8192;
var
  DllHandle : THandle;
  TarFunc   : TTarFunc;
  Command   : AnsiString;
  Output    : array[0..BUFF_SIZE-1] of AnsiChar;
begin
  Result := False;

  //DLLをロード
  DllHandle := LoadLibrary('tar32.dll');
  if DllHandle < HINSTANCE_ERROR then exit;

  try
    //DLL内のTarという関数のアドレスを取得
    @TarFunc := GetProcAddress(DllHandle, 'Tar');
    if @TarFunc = nil then exit;

    //ヒントや警告が表示されるので明示的にキャストしておく
    Command := AnsiString('-x --display-dialog=0 ' +
                 AnsiQuotedStr(SrcPath, '"') + ' ' +
                 AnsiQuotedStr(IncludeTrailingPathDelimiter(DestPath), '"'));

    FillChar(Output, SizeOf(Output), 0);
    try
      //実際にDLL内の関数を実行する部分
      TarFunc(Handle, PAnsiChar(Command), OutPut, BUFF_SIZE);
      AMsg   := String(OutPut);
      Result := True;
    except
    end;
  finally
    FreeLibrary(DllHandle);
  end;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses plArchieverTAR;

{$R *.dfm}

//=============================================================================
//  ファイルの圧縮
//  指定したディレクトリ内のファイル全てを.tar.gz形式で圧縮
//  以下のコードでは，プロジェクトのファルダ下の[Temp]フォルダ内に保存
//
//  tar32.dllで扱える書庫の例
// -----------------------------------------------------
//  形式         定数名               定数値
// -----------------------------------------------------
//  TAR          ARCHIVETYPE_TAR      1
//  TAR.GZ(TGZ)  ARCHIVETYPE_TARGZ    2
//  TAR.Z(TAZ)   ARCHIVETYPE_TARZ     3      展開のみ
//  GZ(GZIP)     ARCHIVETYPE_GZ       4
//  Z            ARCHIVETYPE_Z        5      展開のみ
//  TAR.BZ2      ARCHIVETYPE_TARBZ2   6
//  BZ2          ARCHIVETYPE_BZ2      7
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  Arch      : TplArchieverTAR;
  FileDlg   : TFileOpenDialog;
  RetFlag   : Boolean;
  SrcDir    : String;
  DestFile  : String;
  ResultMsg : string;
begin
  //初期選択フォルダパス
  SrcDir  := ExtractFilePath(Application.ExeName);

  RetFlag := False;
  //Windows Vista以降専用コード
  FileDlg := TFileOpenDialog.Create(nil);
  try
    FileDlg.Options := [fdoPickFolders,
                        fdoPathMustExist,
                        fdoForceFileSystem];
    if FileDlg.Execute then begin
      Update;
      SrcDir  := FileDlg.FileName;
      RetFlag := True;
    end;
  finally
    FreeAndNil(FileDlg);
  end;
  if not RetFlag then exit;

  Screen.Cursor := crHourGlass;
  Arch := TplArchieverTAR.Create(Self);
  try
    //圧縮後のファイル名(フルパス)
    //このプロジェクトのフォルダとする
    //PackFilesメソッドはフォルダが存在しないと自動作成する
    DestFile := ExtractFilePath(Application.ExeName) + 'Temp' + PathDelim + 'Test.tar.gz';

    //圧縮
    RetFlag := Arch.PackFiles(SrcDir, DestFile, ResultMsg);
  finally
    FreeAndNil(Arch);
    Screen.Cursor := crDefault;
  end;

  if RetFlag then begin
    MessageBox(Handle, '圧縮終了', '実行結果', MB_ICONINFORMATION);
  end else begin
    MessageBox(Handle, '圧縮失敗', '実行結果', MB_ICONWARNING);
  end;
end;

//=============================================================================
//  書庫の解凍
//  解凍先のディレクトリがない場合は自動作成して上書き保存
//  以下のコードでは，プロジェクトのフォルダ下の[Temp]フォルダ内に解凍
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  Arch      : TplArchieverTAR;
  SrcFile   : String;
  DestDir   : String;
  ResultMsg : string;
  flgResult : Boolean;
begin
  //解凍対象の書庫ファイルを選択
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  OpenDialog1.Filter     := 'tar (TGZ,TAZ,BZ2) 書庫|*.tgz;*.tar.gz;*.tar.z;*.tar.bz2|'
                           + 'tar 書庫|*.tar|'
                           + 'gz (GZIP) 書庫|*.gz|'
                           + 'z 書庫|*.z|'
                           + 'bz2 (BZIP2) 書庫|*.bz2|';
  OpenDialog1.FileName   := '';
  if not OpenDialog1.Execute then exit;

  Screen.Cursor := crHourGlass;
  Arch := TplArchieverTAR.Create(Self);
  try
    SrcFile := OpenDialog1.FileName;
    DestDir := ExtractFilePath(Application.ExeName) + 'Temp';

    //解凍
    flgResult := Arch.Extract(SrcFile, DestDir, ResultMsg);
  finally
    FreeAndNil(Arch);
    Screen.Cursor := crDefault;
  end;

  if flgResult then begin
    MessageBox(Handle, '解凍終了', '実行結果', MB_ICONINFORMATION);
  end else begin
    MessageBox(Handle, '解凍失敗', '実行結果', MB_ICONWARNING);
  end;
end;

end.

unit plArchieverTAR;

interface

uses
    Windows, Messages, SysUtils, Classes, Controls, Forms;

const
  lpszWMARCEXTRACT   = 'wm_arcextract';


type
  TplArchieverTAR = class(TComponent)
  private
    FHandle : HWND;
  protected
    FDllHandle : THandle;
    function Execute(Cmd: String; var AMsg: String): Boolean;
  public
    constructor Create( AOwner:TComponent ); override;
    destructor Destroy(); override;
    function Extract(SrcPath, DestPath: String; var AMsg: String): Boolean;
    function PackFiles(SrcPath, DestPath: String; var AMsg: String): Boolean;
  end;

implementation

{ TplArchieverTAR }

type
  TTar = function (const hWnd: HWND; szCmdLine: LPCSTR; szOutPut: LPSTR;
    constdwSize: DWORD): Integer; stdcall;

var
  FTar : TTar;

//=============================================================================
//  Create処理
//=============================================================================
constructor TplArchieverTAR.Create(AOwner: TComponent);
begin
  inherited;

  FDllHandle := LoadLibrary('tar32.dll');
  if FDllHandle < HINSTANCE_ERROR then begin
    FDllHandle := 0;
  end else begin
    FHandle := TWinControl(AOwner).Handle;

    //DLL内のTarという関数のアドレスを取得
    @FTar := GetProcAddress(FDllHandle, 'Tar');
  end;
end;

//=============================================================================
//  Destroy処理
//=============================================================================
destructor TplArchieverTAR.Destroy;
begin
  if FDllHandle <> 0 then begin
    FreeLibrary(FDllHandle);
  end;
  FDllHandle := 0;

  inherited;
end;

//=============================================================================
//  圧縮メソッド
//  SrcPath  : 圧縮対象のディレクトリ名(このディレクトリ内のファイルを全て格納)
//  DestPath : 圧縮後のファイル名のフルパス
//
//-----------------------------------------------------------------------------
//  圧縮の種類のコマンドオプションの例
//
//　-z[N]         gzip相当の圧縮．Nは圧縮レベルで1～9(デフォルトは6)
//  --gzip=[N]    同上
//  -B[N]         bzip2相当の圧縮．Nは圧縮レベルで1～9(デフォルトルは9)
//  --bzip(=[N])  同上
//  --bzip2(=[N]) 同上
//  -G            gzipまたはbzip2相当の圧縮のみ実行
//  -J[N]         xz相当の圧縮．Nは圧縮レベルで1～9(デフォルトルは6)
//  --xz(=[N])    同上
//  --lzma(=[N])  lzma相当の圧縮．Nは圧縮レベルで1～9(デフォルトルは6)
//=============================================================================
function TplArchieverTAR.PackFiles(SrcPath, DestPath: String;
  var AMsg: String): Boolean;
var
  FCommand : String;
begin
  Result := False;
  if FDllHandle = 0 then exit;

  ForceDirectories(ExtractFileDir(DestPath));
  FCommand := '-c -z --display-dialog=0 ' +
              AnsiQuotedStr(DestPath, '"') + ' ' +
              AnsiQuotedStr(IncludeTrailingPathDelimiter(SrcPath), '"') + ' ' +
              '*.*';

  //引数を与えて関数を実行
  Result := Execute(FCommand, AMsg);
end;

//=============================================================================
//  解凍メソッド
//  SrcPath  : 解凍対象のファイルのフルパス
//  DestPath : 解凍したファイルを格納するディレクトリ
//=============================================================================
function TplArchieverTAR.Extract(SrcPath, DestPath: String;
  var AMsg: String): Boolean;
var
  FCommand : String;
begin
  Result := False;
  if FDllHandle = 0 then exit;

  FCommand := '-x --display-dialog=0 ' +
              AnsiQuotedStr(SrcPath, '"') + ' ' +
              AnsiQuotedStr(IncludeTrailingPathDelimiter(DestPath), '"');

  //引数を与えて関数を実行
  Result := Execute(FCommand, AMsg);
end;

//=============================================================================
//  圧縮または解凍の実行ルーチン
//  圧縮か解凍かは引数のコマンドで決まる
//=============================================================================
function TplArchieverTAR.Execute(Cmd: String; var AMsg: String): Boolean;
const
  BUFF_SIZE = 8192;
var
  ACommand : AnsiString;
  Output   : array[0..BUFF_SIZE-1] of AnsiChar;
begin
  Result := False;

  if @FTar <> nil then begin
    FillChar(Output, SizeOf(Output), 0);
    //ヒントや警告が表示されるので明示的にキャストしておく
    ACommand := AnsiString(Cmd);
    try
      //実際にDLL内の関数を実行する部分
      //tar32.dll内のTarという関数を実行
      FTar(FHandle, PAnsiChar(ACommand), OutPut, BUFF_SIZE);
      Result := True;
    except
    end;
  end;
  AMsg := String(OutPut);
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Button1: TButton;
    Button2: TButton;
    ProgressBar1: TProgressBar;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  protected
    procedure WndProc(var Message: TMessage); override;
  private
    { Private 宣言 }
    FTotalSize : UInt64;
    FWriteSize : UInt64;
    procedure GetDirFilesSize(ADir: String; var ASumSize: UInt64);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses plArchieverTAR, IOUtils;

{$R *.dfm}

//=============================================================================
//  ファイルの圧縮
//  指定したディレクトリ内のファイル全てを.tar.gz形式で圧縮
//  以下のコードでは，プロジェクトのファルダ下の[Temp]フォルダ内に保存
//
//  tar32.dllで扱える書庫の例
// -----------------------------------------------------
//  形式         定数名               定数値
// -----------------------------------------------------
//  TAR          ARCHIVETYPE_TAR      1
//  TAR.GZ(TGZ)  ARCHIVETYPE_TARGZ    2
//  TAR.Z(TAZ)   ARCHIVETYPE_TARZ     3      展開のみ
//  GZ(GZIP)     ARCHIVETYPE_GZ       4
//  Z            ARCHIVETYPE_Z        5      展開のみ
//  TAR.BZ2      ARCHIVETYPE_TARBZ2   6
//  BZ2          ARCHIVETYPE_BZ2      7
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  Arch      : TplArchieverTAR;
  FileDlg   : TFileOpenDialog;
  RetFlag   : Boolean;
  SrcDir    : String;
  DestFile  : String;
  ResultMsg : string;
begin
  //初期選択フォルダパス
  SrcDir  := ExtractFilePath(Application.ExeName);

  RetFlag := False;
  //Windows Vista以降専用コード
  FileDlg := TFileOpenDialog.Create(nil);
  try
    FileDlg.Options := [fdoPickFolders,
                        fdoPathMustExist,
                        fdoForceFileSystem];
    if FileDlg.Execute then begin
      Update;
      SrcDir  := FileDlg.FileName;
      RetFlag := True;
    end;
  finally
    FreeAndNil(FileDlg);
  end;
  if not RetFlag then exit;

  Screen.Cursor := crHourGlass;
  Arch := TplArchieverTAR.Create(Self);
  try
    //圧縮後のファイル名(フルパス)
    //このプロジェクトのフォルダとする
    //PackFilesメソッドはフォルダが存在しないと自動作成する
    DestFile := ExtractFilePath(Application.ExeName) + 'Temp' + PathDelim + 'Test.tar.gz';

    //圧縮するファイルのサイズを取得
    FTotalSize := 0;
    FWriteSize := 0;
    GetDirFilesSize(SrcDir, FTotalSize);
    ProgressBar1.Max := 1000;
    //圧縮
    RetFlag := Arch.PackFiles(SrcDir, DestFile, ResultMsg);
  finally
    FreeAndNil(Arch);
    Screen.Cursor := crDefault;
  end;

  if RetFlag then begin
    MessageBox(Handle, '圧縮終了', '実行結果', MB_ICONINFORMATION);
  end else begin
    MessageBox(Handle, '圧縮失敗', '実行結果', MB_ICONWARNING);
  end;
end;

//=============================================================================
//  書庫の解凍
//  解凍先のディレクトリがない場合は自動作成して上書き保存
//  以下のコードでは，プロジェクトのフォルダ下の[Temp]フォルダ内に解凍
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  Arch      : TplArchieverTAR;
  SrcFile   : String;
  DestDir   : String;
  ResultMsg : string;
  flgResult : Boolean;
begin
  //解凍対象の書庫ファイルを選択
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  OpenDialog1.Filter     := 'tar (TGZ,TAZ,BZ2) 書庫|*.tgz;*.tar.gz;*.tar.z;*.tar.bz2|'
                           + 'tar 書庫|*.tar|'
                           + 'gz (GZIP) 書庫|*.gz|'
                           + 'z 書庫|*.z|'
                           + 'bz2 (BZIP2) 書庫|*.bz2|';
  OpenDialog1.FileName   := '';
  if not OpenDialog1.Execute then exit;

  Screen.Cursor := crHourGlass;
  Arch := TplArchieverTAR.Create(Self);
  try
    SrcFile := OpenDialog1.FileName;
    DestDir := ExtractFilePath(Application.ExeName) + 'Temp';

    //アーカイブ内のファイルサイズを取得
    FWriteSize := 0;
    FTotalSize := Arch.GetOriginalSize(SrcFile);
    ProgressBar1.Max := 1000;
    //解凍
    flgResult := Arch.Extract(SrcFile, DestDir, ResultMsg);
  finally
    FreeAndNil(Arch);
    Screen.Cursor := crDefault;
  end;

  if flgResult then begin
    MessageBox(Handle, '解凍終了', '実行結果', MB_ICONINFORMATION);
  end else begin
    MessageBox(Handle, '解凍失敗', '実行結果', MB_ICONWARNING);
  end;
end;

//=============================================================================
//  DLLから圧縮・解凍時のメッセージ受信
//  ここではWndProcを使用
//  プログレスバーに進捗状況を表示
//
//  LPExtractingInfo,WM_ARCEXTRACT,ARCEXTRACT_XXXはplArchieverTAR.pas内の定義
//=============================================================================
procedure TForm1.WndProc(var Message: TMessage);
var
  State : UINT;
  lpEis : LPExtractingInfo;
begin
  inherited;

  if Message.Msg = WM_ARCEXTRACT then begin
    State := Message.wParam;
    lpEis := LPExtractingInfo(Message.lParam);
    if State = ARCEXTRACT_INPROCESS then  begin
      if FTotalSize > 0 then begin
        FWriteSize := FWriteSize + lpEis.dwWriteSize;
        ProgressBar1.Position := Trunc(FWriteSize / FTotalSize * 1000);
      end;
    end;

    //処理継続(Message.Result := 1とすれば処理中止)
    //キャンセル機能を追加する場合に利用する
    Message.Result := 0;
  end;
end;

//-----------------------------------------------------------------------------
//  指定ディレクトリ内のファイルの合計サイズを取得
//  引数のASumSizeに合計サイズを返す
//-----------------------------------------------------------------------------
procedure TForm1.GetDirFilesSize(ADir: String; var ASumSize: UInt64);
var
  LSearchPath : string;
  LSearchRec  : TSearchRec;
  LFullPath   : string;
begin
  LSearchPath := IncludeTrailingPathDelimiter(ADir) + '*.*';
  if FindFirst(LSearchPath, faAnyFile, LSearchRec) = 0 then
  begin
    repeat
      if not ((LSearchRec.Name = '..') or (LSearchRec.Name = '.')) then begin
        if (LSearchRec.Attr and faDirectory) = faDirectory then begin
          LFullPath := IncludeTrailingPathDelimiter(ADir) + LSearchRec.Name;
          //パス名を与えて自分自身を呼出(再帰処理)する
          GetDirFilesSize(LFullPath, ASumSize);
        end;
        ASumSize := ASumSize + LSearchRec.Size;
      end;
    until FindNext(LSearchRec) <> 0;
    FindClose(LSearchRec);
  end;
end;

end.

unit plArchieverTAR;

interface

uses
    Windows, Messages, SysUtils, Classes, Controls, Forms;

const
  lpszWMARCEXTRACT     = 'wm_arcextract';
  ARCEXTRACT_BEGIN     = 0; //該当ファイルの処理開始
  ARCEXTRACT_INPROCESS = 1; //該当ファイルの展開中
  ARCEXTRACT_END       = 2; //処理終了.関連メモリを開放
  ARCEXTRACT_OPEN      = 3; //該当書庫の処理の開始
  ARCEXTRACT_COPY      = 4; //ワークファイルの書き戻し

  M_CHECK_ALL_PATH      = $00000100;
  M_CHECK_FILENAME_ONLY = $00000200;
  FNAME_MAX32 = 512;

var
  WM_ARCEXTRACT : UINT;

type
  HARC = HGLOBAL;

  TExtractingInfo = packed record
    dwFileSize       : DWORD;
    dwWriteSize      : DWORD;
    szSourceFileName : array [0..FNAME_MAX32] of AnsiChar;
    dummy1           : array [0..2] of AnsiChar;
    szDestFileName   : array [0..FNAME_MAX32] of AnsiChar;
    dummy            : array [0..2] of AnsiChar;
  end;
  LPEXTRACTINGINFO = ^TExtractingInfo;

  TExtractingInfoEx = packed record
    exinfo           : TExtractingInfo;
    dwCompressedSize : DWORD;
    dwCRC            : DWORD;
    uOSType          : UINT;
    wRatio           : WORD;
    wDate            : WORD;
    wTime            : WORD;
    szAttribute      : array[0..7] of AnsiChar;
    szMode           : array[0..7] of AnsiChar;
  end;
  LPEXTRACTINGINFOEX = ^TExtractingInfoEx;

  TINDIVIDUALINFO = packed record
    dwOrinalSize   : DWORD;
    dwCompressSize : DWORD;
    dwCRC          : DWORD;
    uFlag          : UINT;
    uOSType        : UINT;
    wRatio         : WORD;
    wDate          : WORD;
    wTime          : WORD;
    szFileName     : array [0..FNAME_MAX32] of AnsiChar;
    dummy          : array [0..2] of AnsiChar;
    szAttribute    : array [0..7] of AnsiChar;
    szMode         : array [0..7] of AnsiChar;
  end;
  LPINDIVIDUALINFO = ^TINDIVIDUALINFO;

  TplArchieverTAR = class(TComponent)
  private
    FHandle : HWND;
  protected
    FDllHandle : THandle;
    FArcHandle : HARC;
    function Execute(Cmd: String; var AMsg: String): Boolean;
  public
    constructor Create( AOwner:TComponent ); override;
    destructor Destroy(); override;
    function Extract(SrcPath, DestPath: String; var AMsg: String): Boolean;
    function PackFiles(SrcPath, DestPath: String; var AMsg: String): Boolean;
    function GetOriginalSize(SrcPath: String): UInt64;
  end;

implementation

{ TplArchieverTAR }

type
  //Tar32.DLLのAPIの関数定義
  TTar = function (const hWnd: HWND; szCmdLine: LPCSTR; szOutPut: LPSTR;
    const dwSize: DWORD): Integer; stdcall;
  TTarOpenArchive = function(const hWindow: HWND; szFileName: LPCSTR;
    const dwMode: DWORD): HARC; stdcall;
  TTarCloseArchive = function(ArcHandle: HARC): Integer; stdcall;
  TTarFindFirst = function (ArcHandle: HARC; szWildName: LPCSTR;
    lpSubInfo: LPINDIVIDUALINFO): Integer; stdcall;
  TTarFindNext = function(ArcHandle: HARC; lpSubInfo: LPINDIVIDUALINFO):
    Integer; stdcall;
  TTarSetOwnerWindow = function (hWindows: HWND): BOOL; stdcall;
  TTarClearOwnerWindow = function(): BOOL; stdcall;

var
  FTar                     : TTar;
  FTarOpenArchive          : TTarOpenArchive;
  FTarCloseArchive         : TTarCloseArchive;
  FTarFindFirst            : TTarFindFirst;
  FTarFindNext             : TTarFindNext;
  FTarSetOwnerWindow       : TTarSetOwnerWindow;
  FTarClearOwnerWindow     : TTarClearOwnerWindow;


//=============================================================================
//  Create処理
//=============================================================================
constructor TplArchieverTAR.Create(AOwner: TComponent);
begin
  inherited;

  FDllHandle := LoadLibrary('tar32.dll');
  if FDllHandle < HINSTANCE_ERROR then begin
    FDllHandle := 0;
  end else begin
    //メッセージを登録
    //このユニットを使用するプログラムでWM_ARCEXTRACTメッセージを受信する
    WM_ARCEXTRACT := RegisterWindowMessage(lpszWMARCEXTRACT);

    //このユニット(DLL)を使用するウィンドウのハンドル
    FHandle := TWinControl(AOwner).Handle;

    //DLL内の関数のアドレスを取得
    @FTar             := GetProcAddress(FDllHandle, 'Tar');
    @FTarOpenArchive  := GetProcAddress(FDllHandle, 'TarOpenArchive');
    @FTarCloseArchive := GetProcAddress(FDllHandle, 'TarCloseArchive');
    @FTarFindFirst    := GetProcAddress(FDllHandle, 'TarFindFirst');
    @FTarFindNext     := GetProcAddress(FDllHandle, 'TarFindNext');

    @FTarSetOwnerWindow   := GetProcAddress(FDllHandle, 'TarSetOwnerWindow');
    @FTarClearOwnerWindow := GetProcAddress(FDllHandle, 'TarClearOwnerWindow');

    //FHandleのウィンドウへのメッセージ送信処理開始
    FTarSetOwnerWindow(FHandle);
  end;
end;

//=============================================================================
//  Destroy処理
//=============================================================================
destructor TplArchieverTAR.Destroy;
begin
  if FDllHandle <> 0 then begin
    //メッセージ送信処理終了
    FTarClearOwnerWindow;
    FreeLibrary(FDllHandle);
  end;
  FDllHandle := 0;

  inherited;
end;

//=============================================================================
//  GetOriginalSize
//  圧縮ファイル内のファイルの圧縮前の合計サイズを取得する関数
//=============================================================================
function TplArchieverTAR.GetOriginalSize(SrcPath: String): UInt64;
var
  LSrcPath : AnsiString;
  LMask    : AnsiString;
  LInfo    : TINDIVIDUALINFO;
  LSize    : UInt64;
begin
  LSize  := 0;

  LSrcPath   := AnsiString(SrcPath);
  LMask      := AnsiString('*.*');
  FArcHandle := FTarOpenArchive(FHandle, PAnsiChar(LSrcPath), M_CHECK_ALL_PATH);

  if FArcHandle <> 0 then begin
    if FTarFindFirst(FArcHandle, PAnsiChar(LMask), @LInfo) >= 0 then begin
      repeat
        LSize := LSize + LInfo.dwOrinalSize;
        Application.ProcessMessages;
      until FTarFindNext(FArcHandle, @LInfo) < 0;
    end;
    FTarCloseArchive(FArcHandle);
  end;
  Result := LSize;
end;

//=============================================================================
//  圧縮メソッド
//  SrcPath  : 圧縮対象のディレクトリ名(このディレクトリ内のファイルを全て格納)
//  DestPath : 圧縮後のファイル名のフルパス
//
//-----------------------------------------------------------------------------
//  圧縮の種類のコマンドオプションの例
//
//　-z[N]         gzip相当の圧縮．Nは圧縮レベルで1～9(デフォルトは6)
//  --gzip=[N]    同上
//  -B[N]         bzip2相当の圧縮．Nは圧縮レベルで1～9(デフォルトルは9)
//  --bzip(=[N])  同上
//  --bzip2(=[N]) 同上
//  -G            gzipまたはbzip2相当の圧縮のみ実行
//  -J[N]         xz相当の圧縮．Nは圧縮レベルで1～9(デフォルトルは6)
//  --xz(=[N])    同上
//  --lzma(=[N])  lzma相当の圧縮．Nは圧縮レベルで1～9(デフォルトルは6)
//=============================================================================
function TplArchieverTAR.PackFiles(SrcPath, DestPath: String;
  var AMsg: String): Boolean;
var
  FCommand : String;
begin
  Result := False;
  if FDllHandle = 0 then exit;

  ForceDirectories(ExtractFileDir(DestPath));
  FCommand := '-c -z --display-dialog=0 ' +
              AnsiQuotedStr(DestPath, '"') + ' ' +
              AnsiQuotedStr(IncludeTrailingPathDelimiter(SrcPath), '"') + ' ' +
              '*.*';

  //引数を与えて関数を実行
  Result := Execute(FCommand, AMsg);
end;

//=============================================================================
//  解凍メソッド
//  SrcPath  : 解凍対象のファイルのフルパス
//  DestPath : 解凍したファイルを格納するディレクトリ
//=============================================================================
function TplArchieverTAR.Extract(SrcPath, DestPath: String;
  var AMsg: String): Boolean;
var
  FCommand : String;
begin
  Result := False;
  if FDllHandle = 0 then exit;

  FCommand := '-x --display-dialog=0 ' +
              AnsiQuotedStr(SrcPath, '"') + ' ' +
              AnsiQuotedStr(IncludeTrailingPathDelimiter(DestPath), '"');

  //引数を与えて関数を実行
  Result := Execute(FCommand, AMsg);
end;

//=============================================================================
//  圧縮または解凍の実行ルーチン
//  圧縮か解凍かは引数のコマンドで決まる
//=============================================================================
function TplArchieverTAR.Execute(Cmd: String; var AMsg: String): Boolean;
const
  BUFF_SIZE = 8192;
var
  ACommand : AnsiString;
  Output   : array[0..BUFF_SIZE-1] of AnsiChar;
begin
  Result := False;

  if @FTar <> nil then begin
    FillChar(Output, SizeOf(Output), 0);
    //ヒントや警告が表示されるので明示的にキャストしておく
    ACommand := AnsiString(Cmd);
    try
      //実際にDLL内の関数を実行する部分
      //tar32.dll内のTarという関数を実行
      FTar(FHandle, PAnsiChar(ACommand), OutPut, BUFF_SIZE);
      Result := True;
    except
    end;
  end;

  AMsg := String(OutPut);
end;

end.

implementation

{$R *.dfm}

  function Tar(const hWnd: HWND; szCmdLine: LPCSTR; szOutPut: LPSTR;
    constdwSize: DWORD): Integer; stdcall; external 'tar32.dll';


// TForm1.Button1Clickのコードは同じなので省略    

//-----------------------------------------------------------------------------
//  tar32.dll内のTarという関数を使用して書庫を解凍する
//-----------------------------------------------------------------------------
function TForm1.ExtractTar(SrcPath, DestPath: String;
  var AMsg: String): Boolean;
const
  BUFF_SIZE = 8192;
var
  Command   : AnsiString;
  Output    : array[0..BUFF_SIZE-1] of AnsiChar;
begin
  Result := False;

  //ヒントや警告が表示されるので明示的にキャストしておく
  Command := AnsiString('-x --display-dialog=0 ' +
               AnsiQuotedStr(SrcPath, '"') + ' ' +
               AnsiQuotedStr(IncludeTrailingPathDelimiter(DestPath), '"'));

  FillChar(Output, SizeOf(Output), 0);
  try
    //実際にDLL内の関数を実行する部分
    Tar(Handle, PAnsiChar(Command), OutPut, BUFF_SIZE);
    AMsg   := String(OutPut);
    Result := True;
  except
  end;
end;

end.