multifrm.pas

UPXShell 压缩解压缩Windows下的exe和dll文件, 其原理基于加壳原理, UPX也是一个Windows下的可执行文件加壳工具

unit MultiFrm;

interface

uses
  Windows, Messages, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Gauges, ComCtrls;
  (* CheckLst, *)

type
  TFileRec = record
    Skip: boolean;
    FullName: string;
    FileName: string;
    FilePath: string;
    FileSize: integer;
    CompressedSize: integer;
    CompressionResult: boolean;
  end;

type
  TMultiForm = class(TForm)
    grpSearch: TGroupBox;
    btnBrowse: TButton;
    chkRecurse: TCheckBox;
    lblDir: TLabel;
    cmbType: TComboBox;
    lvFiles: TListView;
    pnlBottom: TPanel;
    lblCurrent: TLabel;
    lblOverall: TLabel;
    lblTotalCap: TLabel;
    lblSelectedCap: TLabel;
    lblTimeCap: TLabel;
    lblTotal: TLabel;
    lblSelected: TLabel;
    lblTime: TLabel;
    btnPack: TButton;
    btnExit: TButton;
    btnScan: TButton;
    pnlCurrent: TPanel;
    pgbCurrent: TGauge;
    sttRatio: TStaticText;
    pnlOverall: TPanel;
    pgbOverall: TGauge;
    procedure FormCreate(Sender: TObject);
    procedure btnBrowseClick(Sender: TObject);
    procedure btnScanClick(Sender: TObject);
    procedure btnPackClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure lvFilesKeyUp(Sender: TObject; var Key: word;
      Shift: TShiftState);
    procedure lvFilesMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: integer);
  private
    Active: boolean;
    FGlobFileName: string;
    //backup GlobFileName variable to restore it afterwards
    FFileName: string[5];
    //    FFileList: array [1..2] of TStringList;
    FFiles: array of TFileRec;
    procedure FindFiles(APath: string);
    function GetDirectoryName(const Dir: string): string;
    procedure FindFilesNR(APath: string);
    procedure PackFiles;
    function PackFile(FileName: string): boolean;
    { Private declarations }
  public
    FDirName: string;
    { Public declarations }
  end;

var
  MultiForm: TMultiForm;
  hStdOut:   THandle;

implementation

uses
  FileCtrl, TypInfo, SysUtils, Math,
  Shared, Translator, Globals,
  MainFrm;

{$R *.dfm}

function TMultiForm.GetDirectoryName(const Dir: string): string;
{ This function formats the directory name so that it is a valid
  directory containing the back-slash (\) as the last character. }
begin
  if Dir[Length(Dir)] <> '\' then
  begin
    Result := Dir + '\';
  end
  else begin
    Result := Dir;
  end;
end;

procedure TMultiForm.FindFiles(APath: string);
{ This is a procedure which is called recursively so that it finds the
  file with a specified mask through the current directory and its
  sub-directories. }
var
  FSearchRec, DSearchRec: TSearchRec;
  FindResult: integer;

  function IsDirNotation(const ADirName: string): boolean;
  begin
    Result := (ADirName = '.') or (ADirName = '..');
  end;

begin
  APath      := GetDirectoryName(APath); // Obtain a valid directory name
  { Find the first occurrence of the specified file name }
  FindResult := FindFirst(APath + FFileName, faAnyFile {+faHidden+
                          faSysFile+faReadOnly}, FSearchRec);
  try
    { Continue to search for the files according to the specified
      mask. If found, add the files and their paths to the listbox.}
    while FindResult = 0 do
    begin
      SetLength(FFiles, length(FFiles) + 1);
      with FFiles[high(FFiles)] do
      begin
        Skip     := False;
        FullName := APath + FSearchRec.Name;
        FileName := ExtractFileName(APath + FSearchRec.Name);
        FilePath := APath;
        FileSize := GetFileSize(FullName);
        CompressedSize := -1;
        CompressionResult := False;
      end;
      FindResult := FindNext(FSearchRec);
    end;
    { Now search the sub-directories of this current directory. Do this
      by using FindFirst to loop through each subdirectory, then call
      FindFiles (this function) again. This recursive process will
      continue until all sub-directories have been searched. }
    FindResult := FindFirst(APath + '*.*', faDirectory, DSearchRec);
    while FindResult = 0 do
    begin
      if ((DSearchRec.Attr and faDirectory) = faDirectory) and not
        IsDirNotation(DSearchRec.Name) then
      begin
        FindFiles(APath + DSearchRec.Name);
      end; // Recursion here
      FindResult := FindNext(DSearchRec);
    end;
  finally
    FindClose(FSearchRec);
  end;
end;

{ This one is used to search files without directory
  recursion }
procedure TMultiForm.FindFilesNR(APath: string);
var
  SearchRec:  TSearchRec;
  FindResult: integer;
begin
  APath      := GetDirectoryName(APath);
  FindResult := FindFirst(APath + FFileName, faAnyFile {+faHidden+
                          faSysFile+faReadOnly}, SearchRec);
  while FindResult = 0 do
  begin
    SetLength(FFiles, length(FFiles) + 1);
    with FFiles[high(FFiles)] do
    begin
      Skip     := False;
      FullName := APath + SearchRec.Name;
      FileName := ExtractFileName(APath + SearchRec.Name);
      FilePath := APath;
      FileSize := GetFileSize(FullName);
      CompressedSize := -1;
      CompressionResult := False;
    end;
    FindResult := FindNext(SearchRec);
  end;
end;

procedure TMultiForm.FormCreate(Sender: TObject);
begin
  cmbType.ItemIndex := 1;
  Active := False;
  FGlobFileName := GlobFileName;
end;

procedure TMultiForm.btnBrowseClick(Sender: TObject);
var
  dir: string;
begin
  if SelectDirectory(TranslateMsg('Select directory to compress:'),
    '', dir) then
  begin
    FDirName := Dir;
    lblDir.Caption := FDirName;
  end;
  {lblSelectedCap.Visible:= false;
  lblSelected.Visible:= false;
  lblTotalCap.Visible:= false;
  lblTotal.Visible:= false;
  lblTimeCap.Visible:= false;
  lblTime.Visible:= false;
  TreeViewForm := TTreeViewForm.Create(Self);
  try
    if TreeViewForm.ShowModal = mrOk then
      lblDir.Caption := FDirName;
  finally
    TreeViewForm.Release;
  end;}
end;

procedure EnableButtons(Enable: boolean);
begin
  with MultiForm do
  begin
    Active := Enable;
    btnBrowse.Enabled := Enable;
    cmbType.Enabled := Enable;
    chkRecurse.Enabled := Enable;
    btnScan.Enabled := Enable;
    btnPack.Enabled := Enable;
    btnExit.Enabled := Enable;
{    if Enable then
    begin
      lblTotalCap.Visible:= true;
      lblTotal.Visible:= true;
//      lblTotal.Caption:= inttostr(clbFiles.Items.Count);
    end;}
  end;
end;

procedure FillView;
var
  lItem: TListItem;
  i:     integer;
begin
  with MultiForm do
  begin
    for i := low(FFiles) to high(FFiles) do
    begin
      lItem := MultiForm.lvFiles.Items.Add;
      lItem.Caption := FFiles[i].FileName;
      lItem.SubItems.Add(FFiles[i].FilePath);
      lItem.SubItems.Add(ProcessSize(FFiles[i].FileSize));
      lItem.SubItems.Add('---');
      lItem.SubItems.Add('---');
    end;
  end;
end;

procedure TMultiForm.btnScanClick(Sender: TObject);
begin
  if ((lblDir.Caption = TranslateMsg('N/A')) or (lblDir.Caption = '')) then
  begin
    ShowMessage(TranslateMsg('No directory selected'));
    Exit;
  end
  else begin
    Active := True;
    EnableButtons(False);
    lvFiles.Clear;
    SetLength(FFiles, 0);
    Screen.Cursor := crHourGlass;
    FFileName     := cmbType.Text;
    if chkRecurse.Checked then
    begin
      FindFiles(lblDir.Caption);
    end
    else begin
      FindFilesNR(lblDir.Caption);
    end;
    FillView;
    EnableButtons(True);
    Screen.Cursor := crDefault;
    Active := False;
  end;
end;

procedure GetProgress(ProcessInfo: TProcessInformation; Compress: boolean);

  procedure SetStatBar(Value: integer);
  var
    TrackLen: integer;
    StatLen:  integer;
  begin
    TrackLen := MultiForm.pgbCurrent.Width;
    StatLen  := round((TrackLen / 100) * Value);
    MultiForm.sttRatio.Width := StatLen - 3;
  end;

type
  TLine = array[0..79] of char;