unit1.pas

Example of using unrar lib (unrar.dll not included!). Delphi 7

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, UnRar, JvBaseDlg, JvSelectDirectory, ActnList,
  StdCtrls, Grids, JvExGrids, JvStringGrid, Mask, JvExMask, JvToolEdit;
const
  EXTRACT = 0;
  TEST    = 1;
  STREAM  = 2;

type
  TStringGridExSortType = (srtAlpha, srtInteger, srtDouble);
  TForm1 = class(TForm)
    ProgressBar1: TProgressBar;
    JvFilenameEdit1: TJvFilenameEdit;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    StaticText1: TStaticText;
    StaticText2: TStaticText;
    StaticText3: TStaticText;
    StaticText4: TStaticText;
    StaticText5: TStaticText;
    StaticText6: TStaticText;
    StaticText7: TStaticText;
    StaticText8: TStaticText;
    ActionList1: TActionList;
    Action1: TAction;
    AcListArc: TAction;
    StatusBar1: TStatusBar;
    AcSortGrid: TAction;
    GroupBox2: TGroupBox;
    Memo2: TMemo;
    GroupBox3: TGroupBox;
    SG: TJvStringGrid;
    GroupBox4: TGroupBox;
    RB1: TRadioButton;
    RB2: TRadioButton;
    RB3: TRadioButton;
    DoIt: TButton;
    JvSelectDirectory1: TJvSelectDirectory;
    procedure Action1Execute(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure AcListArcExecute(Sender: TObject);
    procedure ShowComment(CmtBuf2: PChar);
//    function CallbackProc(msg: UINT; UserData, P1, P2: integer) :integer; stdcall;
    procedure ShowArcInfo(Flags: UINT; ArcName: PChar);
    procedure OutOpenArchiveError(Error: Integer; ArcName: PChar);
    procedure OutProcessFileError(Error: Integer);
    procedure GridSort(SG: TStringGrid; ByColNumber, FromRow, ToRow: integer;
      SortType: TStringGridExSortType = srtAlpha);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  MS:TMemoryStream;

implementation

{$R *.dfm}
procedure TForm1.ShowComment(CmtBuf2: PChar);
begin
  Form1.Memo2.Lines.Clear;
  Form1.Memo2.Lines.Add(CmtBuf2);
end;

function CallbackProc(msg: UINT; UserData, P1, P2: integer) :integer; stdcall;
var
  Ch: Char;
  I: Integer;
  C: PChar;
  S: String;
begin
  Result := 0;
  case msg of
    UCM_CHANGEVOLUME:
      if (P2 = RAR_VOL_ASK) then begin
        ShowMessage('Insert disk with ' + PChar(P1) );
        Readln(Ch);
        if (UpCase (Ch) = 'Q') then
          Result := -1;
      end;
    UCM_NEEDPASSWORD:
      begin
        S := InputBox('Password', 'Please enter the password for this archive:', '');
        C := PChar(S);
        Move(pointer(C)^, pointer(p1)^, StrLen(C) + 1);
          //+1 to copy the zero
      end;
    UCM_PROCESSDATA: begin
      if (UserData <> 0) and (PINT (UserData)^ = 2) then
      begin
        // Windows.WriteFile fails on big data
        for I := 0 to P2 - 1 do
          MS.Write(PChar(P1 + I)^,1);
      end;
    end;
  end;
end;

procedure TForm1.ShowArcInfo(Flags: UINT; ArcName: PChar);
  function CheckFlag(FlagBit: UINT): string;
  begin
    if (Flags and FlagBit) > 0 then result := 'yes' else result := 'no';
  end;
begin
  Form1.StaticText1.Caption := CheckFlag(1);        // Volume
  Form1.GroupBox2.visible:=(Flags and 2) > 0;       // Bit 2 'Comment:',
  Form1.StaticText2.Caption := CheckFlag(4);        // 'Locked:',
  Form1.StaticText3.Caption := CheckFlag(8);        // 'Solid:',
  Form1.StaticText4.Caption := CheckFlag(16);       // 'New naming:',
  Form1.StaticText5.Caption := CheckFlag(32);       // 'Authenticity:',
  Form1.StaticText6.Caption := CheckFlag(64);       // 'Recovery:',
  Form1.StaticText7.Caption := CheckFlag(128);      // 'Encr.headers:',
  Form1.StaticText8.Caption := CheckFlag(256);      // 'First volume:'
end;

procedure TForm1.OutOpenArchiveError(Error: Integer; ArcName: PChar);
var
  errmes:string;
begin
  case Error of
    ERAR_NO_MEMORY:   errmes := 'Not enough memory';
    ERAR_EOPEN:       errmes :='Cannot open '+ArcName;
    ERAR_BAD_ARCHIVE: errmes := ArcName+' is not RAR archive';
    ERAR_BAD_DATA:    errmes := ArcName+': archive header broken';
    ERAR_UNKNOWN:     errmes := 'Unknown error';
  end;
  ShowMessage(errmes);
end;

procedure TForm1.OutProcessFileError(Error: Integer);
var
  errmes:string;
begin
  case Error of
    ERAR_UNKNOWN_FORMAT: errmes := 'Unknown archive format';
    ERAR_BAD_ARCHIVE:    errmes := 'Bad volume';
    ERAR_ECREATE:        errmes := 'File create error';
    ERAR_EOPEN:          errmes := 'Volume open error';
    ERAR_ECLOSE:         errmes := 'File close error';
    ERAR_EREAD:          errmes := 'Read error';
    ERAR_EWRITE:         errmes := 'Write error';
    ERAR_BAD_DATA:       errmes := 'CRC error';
    ERAR_UNKNOWN:        errmes := 'Unknown error';
  end;
  ShowMessage(errmes+' '+IntToStr(Error));
end;

procedure TForm1.GridSort(SG: TStringGrid; ByColNumber, FromRow, ToRow: integer;
  SortType: TStringGridExSortType = srtAlpha);
var
  Temp: TStringList;

  function SortStr(Line: string): string;
  var
    RetVar: string;
  begin
    case SortType of
      srtAlpha: Retvar := Line;
      srtInteger: Retvar := FormatFloat('000000000', StrToIntDef(trim(Line),
        0));
      srtDouble:
        try
          Retvar := FormatFloat('000000000.000000', StrToFloat(trim(Line)));
        except
          RetVar := '0.00';
        end;
    end;

    Result := RetVar;
  end;

  // 绣牦瘃桠睇