// Пример использования unarc.dll
//


unit main;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    pb: TProgressBar;
    Edit1: TEdit;
    Label1: TLabel;
    Edit2: TEdit;
    Label2: TLabel;
    Button4: TButton;
    Button5: TButton;
    OpenDialog1: TOpenDialog;
    Label3: TLabel;
    Label4: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type TUnarcCallBack=function (what: PAnsiChar; int1, int2: Integer; str: PAnsiChar): Integer;stdcall;

var
  Form1:TForm1;
  FreeArcExtract: function(callback: TUnarcCallBack; cmd1,cmd2,cmd3,cmd4,cmd5,cmd6,cmd7,cmd8,cmd9,cmd10: PAnsiChar): integer; cdecl;

implementation


{$R *.dfm}


const UnarcTest='UnarcTest';
var
  CfgOptExt,PassOptExt,WorkOptExt:PAnsiChar;
  LastExtractedFile,ExtractedFile,InputFileExt,OutputPathExt:string;
  totalUncompressedMb,Percent,LastPercent:integer;
  UnarcDone,UnarcError:boolean;
  Cancel:integer;
  UnarDLLHandle:THandle=0;
  StartUnpackTime,DeltaTime:Cardinal;
  ProcessStarted:boolean=false;

//коды ошибок unarc.dll

const
{ FREEARC_OK=                            0;   (* ALL RIGHT *)
 FREEARC_ERRCODE_GENERAL=               -1;   (* Some error when (de)compressing *)
 FREEARC_ERRCODE_INVALID_COMPRESSOR=    -2;   (* Invalid compression method or parameters *)
 FREEARC_ERRCODE_ONLY_DECOMPRESS=       -3;   (* Program builded with FREEARC_DECOMPRESS_ONLY, so don't try to use compress *)
 FREEARC_ERRCODE_OUTBLOCK_TOO_SMALL=    -4;   (* Output block size in (de)compressMem is not enough for all output data *)
 FREEARC_ERRCODE_NOT_ENOUGH_MEMORY=     -5;   (* Can't allocate memory needed for (de)compression *)
 FREEARC_ERRCODE_READ=                  -6;   (* Error when reading data *)
 FREEARC_ERRCODE_BAD_COMPRESSED_DATA=   -7;   (* Data can't be decompressed *)
 FREEARC_ERRCODE_NOT_IMPLEMENTED=       -8;   (* Requested feature isn't supported *)
 FREEARC_ERRCODE_NO_MORE_DATA_REQUIRED= -9;   (* Required part of data was already decompressed *)
 FREEARC_ERRCODE_OPERATION_TERMINATED= -10;   (* Operation terminated by user *)
 FREEARC_ERRCODE_WRITE=                -11;   (* Error when writing data *)
 FREEARC_ERRCODE_BAD_CRC=              -12;   (* File failed CRC check *)
 FREEARC_ERRCODE_BAD_PASSWORD=         -13;   (* Password/keyfile failed checkcode test *)
 FREEARC_ERRCODE_BAD_HEADERS=          -14;   (* Archive headers are corrupted *)
 FREEARC_ERRCODE_INTERNAL=             -15;   (* It should never happen: implementation error. Please report this bug to developers! *)
}
ErrCodeTableMax=15;

ErrCodeTable:array[1..ErrCodeTableMax]of PAnsiChar=(
     nil,                                                                  // -1
    'Неизвестный метод сжатия архива!',                                    // -2
     nil,                                                                  // -3
    'Выходной блок данных слишком мал!',                                   // -4
    'Не хватает памяти!',                                                  // -5
    'Невозможно считать данные!',                                          // -6
    'Архив поврежден!',                                                    // -7
    'Необходимые функции не поддерживаются библиотекой!',                  // -8
    'Запрошенные данные уже были распакованы!',                            // -9
     nil,                                                                  // -10
    'Невозможно записать данные на диск!',                                 // -11
    'Не совпадает контрольная сумма!',                                     // -12
    'Неверный пароль!',                                                    // -13
    'Заголовок архива поврежден!',                                         // -14
    'Внутренняя ошибка библиотеки!');                                      // -15

UnArcExcept0='Произошла ошибка при распаковке!';
UnArcExcept1='Произошла ошибка при распаковке: ';
UnArcExcept2='Unarc.dll вернул код ошибки: ';

function GetExePath(Instance: THandle):string;
var
  TheFileName: array[0..511] of char;
begin
  FillChar(TheFileName, sizeof(TheFileName), #0);
  GetModuleFileName(Instance, TheFileName, sizeof(TheFileName));
  result:=string(TheFileName);
end;

function MyUnarcCallBack (what: PAnsiChar; Mb, sizeArc: integer; str: PAnsiChar): Integer;stdcall;
var ArcErrCode:integer;
    ArcErrStr:PAnsiChar;
begin
   if what='filename' then begin
      ExtractedFile:=string(str);
//      Form1.Memo1.Lines.Add('Распаковывается '+string(str)+'...');
   end else
      if what='origsize' then
         totalUncompressedMb:=Mb
      else
         if (what='write') and (totalUncompressedMb>0) then
            Percent:=round((Mb/totalUncompressedMb)*1000)
         else
            if (what='quit') and (Mb<0) and (Mb<>-10) then begin
               ArcErrCode:=abs(Mb);
               ArcErrStr:=nil;
               if ArcErrCode<=ErrCodeTableMax then begin
                  ArcErrStr:=ErrCodeTable[ArcErrCode];
               end;
               if ArcErrStr<>nil then begin
                  if str<>nil then begin
                     Form1.Memo1.Lines.Add(UnArcExcept1+ArcErrStr);
                     Form1.Memo1.Lines.Add(UnArcExcept2+IntToStr(-ArcErrCode));
                     Form1.Memo1.Lines.Add(string(str));
                  end else begin
                     Form1.Memo1.Lines.Add(UnArcExcept1+ArcErrStr);
                     Form1.Memo1.Lines.Add(UnArcExcept2+IntToStr(-ArcErrCode));
                  end;
               end else
                  if str<>nil then begin
                     Form1.Memo1.Lines.Add(UnArcExcept0);
                     Form1.Memo1.Lines.Add(UnArcExcept2+IntToStr(-ArcErrCode));
                     Form1.Memo1.Lines.Add(string(str));
                  end else begin
                     Form1.Memo1.Lines.Add(UnArcExcept0);
                     Form1.Memo1.Lines.Add(UnArcExcept2+IntToStr(-ArcErrCode));
                  end;
               UnarcError:=true;
            end;
   if (what='overwrite?') or (what='password?')
      then begin if UnarcError then result:=ord('q') else result:=ord('n'); end
      else begin if UnarcError then result:=-127 else result:=0; end;
end;

procedure UnarcThread(data:integer);stdcall;
var x,y:integer;
    cmd:array[1..6]of PAnsiChar;
label ExitUnarc;
begin
   if FreeArcExtract(@MyUnarcCallBack, 'l', '--', Pchar(AnsiToUtf8(InputFileExt)), nil, nil , nil, nil, nil, nil, nil)>=0 then begin
      cmd[1]:=CfgOptExt;
      cmd[2]:=PassOptExt;
      cmd[3]:=WorkOptExt;
      cmd[4]:=PAnsiChar(AnsiToUtf8('-dp'+OutputPathExt));
      cmd[5]:='--';
      cmd[6]:=PChar(AnsiToUtf8(InputFileExt));
      for x:=1 to 3 do
         while cmd[x]=nil do begin
            for y:=x+1 to 6 do
               cmd[y-1]:=cmd[y];
            cmd[6]:=nil;
         end;
      FreeArcExtract(@MyUnarcCallBack,'x','-o+',cmd[1],cmd[2],cmd[3],cmd[4],cmd[5], cmd[6], nil, nil);
   end else UnarcError:=true;
   UnarcDone:=true;
   ExitThread(0);
end;

function ArcExtract(InputFile, OutputPath, Password, CfgFile, WorkPath: string):boolean;
var sa: TSecurityAttributes;
    ThreadID:Cardinal;
begin
  result:=false;
  try
    repeat
      if (InputFile='') or not FileExists(InputFile) then begin
         Form1.Memo1.Lines.Add('Неверно задан входной файл!');
         break;
      end;
      if (CfgFile<>'') and FileExists(CfgFile) then CfgOptExt:=PAnsiChar(AnsiToUtf8('-cfg'+CfgFile))
         else CfgOptExt:=nil;
      if Password<>'' then PassOptExt:=PAnsiChar(AnsiToUtf8('-p'+Password))
         else PassOptExt:=nil;
      if (WorkPath<>'') then WorkOptExt:=PAnsiChar(AnsiToUtf8('-w'+WorkPath))
         else WorkOptExt:=nil;
      Percent:=0;
      LastPercent:=0;
      totalUncompressedMb:=0;
      ExtractedFile:='';
      LastExtractedFile:='';
      UnarcDone:=false;
      UnarcError:=false;
      InputFileExt:=InputFile;
      OutputPathExt:=OutputPath;
      if UnarDLLHandle=0 then begin
         UnarDLLHandle:=LoadLibrary(PAnsiChar(ExtractFilePath(GetExePath(Hinstance))+'unarc.dll'));
         if UnarDLLHandle=0 then begin
            Form1.Memo1.Lines.Add('Не найдена библиотека unarc.dll!');
            break;
         end;
         FreeArcExtract:=GetProcAddress(UnarDLLHandle,'FreeArcExtract');
      end;
      StartUnpackTime:=GetTickCount;
      sa.nLength := sizeof(sa);
      sa.bInheritHandle := TRUE;
      sa.lpSecurityDescriptor := nil;
      BeginThread(@sa,0,@UnarcThread,nil,0,ThreadID);
      while not UnarcDone do begin
         Application.ProcessMessages;
         sleep(25);
         if Cancel<0 then UnarcError:=true;
         Form1.pb.Position:=Percent;
         DeltaTime:=(GetTickCount-StartUnpackTime) div 1000;
         if {(DeltaTime>0)and}(Percent>LastPercent)and(Percent<>0) then begin
             LastPercent:=Percent;
             Form1.Label4.Caption:=IntToStr(Percent div 10)+'.'+IntToStr(Percent mod 10)+'%';
             Form1.Label3.Caption:='Осталось времени: '+IntToStr(round(DeltaTime/(Percent/1000)-DeltaTime))+' cек';
         end;
         if ExtractedFile<>LastExtractedFile then begin
            Form1.Memo1.Lines.Add('Распаковывается '+ExtractedFile);
            LastExtractedFile:=ExtractedFile;
         end;
      end;
      result:=not UnarcError;
    until true;
  except
     Form1.Memo1.Lines.Add('Возникла непредвиденная ошибка!');
  end;
end;



procedure TForm1.Button1Click(Sender: TObject);
begin
  if ProcessStarted then exit;
  ProcessStarted:=true;
  Memo1.Clear;
  pb.Position := 0;
  Cancel:=0;
  if not ArcExtract(Edit1.Text,Edit2.Text,'','','') then begin
    Memo1.Lines.Add('');
    Memo1.Lines.Add('Распаковка прервана!');
    pb.Position := 0;
  end else begin
    Memo1.Lines.Add('');
    Memo1.Lines.Add('Распаковка успешно завершена. Извлечено '+IntToStr(totalUncompressedMb)+' Мбайт.');
    pb.Position := 1000;
  end;
  ProcessStarted:=false;
  Label3.Caption:='';
  Label4.Caption:='';

end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Cancel := -127;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  OpenDialog1.InitialDir:=GetCurrentDir;
  if OpenDialog1.Execute then
     Edit1.Text := OpenDialog1.FileName;
end;

function SelectDir(TitleName:string):string;
var
  lpItemID : PItemIDList;
  BrowseInfo : TBrowseInfo;
  DisplayName : array[0..MAX_PATH] of char;
  TempPath : array[0..MAX_PATH] of char;

begin
  FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
  BrowseInfo.hwndOwner := Form1.Handle;
  BrowseInfo.pszDisplayName := @DisplayName;
  BrowseInfo.lpszTitle := PAnsiChar(TitleName);
  BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI or
    BIF_BROWSEINCLUDEFILES * Ord(false) or
    $0200 * Ord(not true);
  lpItemID := SHBrowseForFolder(BrowseInfo);
  if lpItemId <> nil then
  begin
    SHGetPathFromIDList(lpItemID, TempPath);
    Result:=TempPath;
    GlobalFreePtr(lpItemID);
  end;
end;


procedure TForm1.Button5Click(Sender: TObject);
begin
  Edit2.Text := SelectDir('Выберите путь');
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
   if ProcessStarted then begin
      Action:=caNone;
      Cancel:=-127;
   end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
   if UnarDLLHandle<>0 then FreeLibrary(UnarDLLHandle);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  Label4.BringToFront;

end;

end.
