multifrm.pas

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

var
  EC:     cardinal;
  c, progress: integer;
  Offset: integer;
  Text:   array[0..79] of char;
  CursorPos: TCoord;
  CharsRead: DWord;
  Line:   TLine;
  MyString: string;
begin
  GetExitCodeProcess(ProcessInfo.hProcess, ec);
  CursorPos.x := 0;
  CursorPos.y := 0;
  DecimalSeparator := '.'; //In localized Windows it could be ','
  Progress := 0;
  Offset   := 0;
  while True do
  begin
    ReadConsoleOutputCharacter(hStdOut, Line, 80, CursorPos, charsRead);
    Offset := pos('[', Line) - 1;
    if Offset > -1 then
    begin
      break;
    end
    else begin
      Inc(CursorPos.Y);
    end;
    if CursorPos.Y > 20 then
    begin //If we get here - something's wrong
      CursorPos.Y := 0;
      GetExitCodeProcess(ProcessInfo.hProcess, ec);
      if ec <= 2 then
      begin
        Exit;
      end;
    end;
  end;
  while ec > 2 do
  begin
    charsRead := 0;
    ReadConsoleOutputCharacter(hStdOut, Text, 80, CursorPos, charsRead);
    if Line[Offset] = '[' then
    begin
      for c := Offset + Progress + 1 to Offset + 66 do
      begin
        if Line[c] = '*' then
        begin
          Inc(Progress);
        end
        else begin
          Break;
        end;
      end;
      if Compress then
      begin
        MyString := Line[69] + Line[70] + Line[71] + Line[72];
        SetStatBar(round(strtofloat(MyString)));
      end;
      MultiForm.pgbCurrent.Progress := floor((Progress / 64) * 100);
    end;
    if Progress = 64 then
    begin
      Exit;
    end;
    sleep(50);
    Application.ProcessMessages;
    GetExitCodeProcess(ProcessInfo.hProcess, ec);
  end;
end;

procedure UnSetReadOnly(const FileName: string);
var
  Attrib: cardinal;
begin
  Attrib := GetFileAttributes(PChar(FileName));
  if (Attrib and FILE_ATTRIBUTE_READONLY) > 0 then
  begin
    SetFileAttributes(PChar(FileName), Attrib - FILE_ATTRIBUTE_READONLY);
  end;
end;

function TMultiForm.PackFile(FileName: string): boolean;
var
  si: Tstartupinfo;
  p:  Tprocessinformation;
  ExitCode: cardinal;
begin
  FillChar(Si, SizeOf(Si), 0);
  with Si do
  begin
    cb      := SizeOf(Si);
    dwFlags := startf_UseShowWindow;
    wShowWindow := 2;
    si.lpTitle := PChar('UPX Shell - MultiPack Engine');
  end;
  GlobFileName := FileName;
  FileName     := GetCompressParams;
  SetCurrentDir(WorkDir);
  UnSetReadOnly(FileName);
  ShowWindow(findwindow(nil, PChar('UPX Shell - MultiPack Engine')), 0);
  Createprocess(nil, PChar(FileName), nil, nil, True,
    Create_default_error_mode + GetPriority, nil, PChar(workdir), si, p);
  GetProgress(p, not MainForm.chkDecomp.Checked);
  WaitForSingleObject(p.hProcess, infinite);
  GetExitCodeProcess(p.hProcess, ExitCode);
  if ExitCode = 0 then
  begin
    Result := True;
  end
  else begin
    Result := False;
  end;
end;

procedure TMultiForm.PackFiles;

  procedure SetPackedItem(Index: integer; Success: boolean = True);
  var
    lItem: TListItem;
  begin
    if Success then
    begin
      FFiles[Index].CompressionResult := True;
      FFiles[Index].CompressedSize := GetFileSize(FFiles[Index].FullName);
      lItem := lvFiles.FindCaption(0, FFiles[Index].FileName,
        False, True, True);
      if lItem <> nil then
      begin
        lItem.SubItems[2] := ProcessSize(FFiles[Index].CompressedSize);
        lItem.SubItems[3] := TranslateMsg('OK');
      end;
    end
    else begin
      FFiles[Index].CompressionResult := False;
      lItem := lvFiles.FindCaption(0, FFiles[Index].FileName,
        False, True, True);
      if lItem <> nil then
      begin
        lItem.SubItems[3] := TranslateMsg('Failed');
      end;
    end;
  end;

  procedure CreateConsole;
  var
    CursorPos:    TCoord;
    ConsoleTitle: array[1..MAX_PATH] of char;
  begin
    AllocConsole;
    GetConsoleTitle( @ConsoleTitle, MAX_PATH);
    ShowWindow(FindWindow(nil, @ConsoleTitle), 0);
    Application.BringToFront;
    hStdOut     := GetStdHandle(STD_OUTPUT_HANDLE);
    CursorPos.X := 500;
    CursorPos.Y := 50;
    SetConsoleScreenBufferSize(hStdOut, CursorPos);
    CursorPos.X := 0;
    CursorPos.Y := 0;
    SetConsoleCursorPosition(hStdOut, CursorPos);
    MultiForm.pgbCurrent.Progress := 0;
    MultiForm.pgbOverall.Progress := 0;
  end;

var
  StartTime: int64;

  function QueryTime(GetTime: boolean): string;
  var
    Frequency, EndTime: int64;
    Time: string[5];
  begin
    if GetTime then
    begin
      QueryPerformanceFrequency(Frequency);
      QueryPerformanceCounter(EndTime);
      Time   := floattostr((EndTime - StartTime) / Frequency);
      Result := Time;
    end
    else begin
      QueryPerformanceCounter(StartTime);
      Result := '';
    end;
  end;

var
  i: integer;
  c: cardinal;
  CursorPos: TCoord;
begin
  CursorPos.X := 0;
  CursorPos.Y := 0;
  c := 0;
  CreateConsole;
  QueryTime(False);
  ExtractUPX(edExtract);
  for i := low(FFiles) to high(FFiles) do
  begin
    if not FFiles[i].Skip then
    begin
      if PackFile(FFiles[i].FullName) then
      begin
        SetPackedItem(i);
      end
      else begin
        SetPackedItem(i, False);
      end;
      MultiForm.pgbOverall.Progress := round((i + 1) / length(FFiles) * 100);
      MultiForm.sttRatio.Width      := 0;
      SetConsoleCursorPosition(hStdOut, CursorPos);
      FillConsoleOutputCharacter(hStdOut, #0, 1500, CursorPos, c);
    end;
  end;
  MultiForm.pgbCurrent.Progress := 100;
  MultiForm.pgbOverall.Progress := 100;
  ExtractUPX(edDelete);
  MultiFOrm.lblTimeCap.Visible := True;
  MultiForm.lblTime.Visible    := True;
  MultiForm.lblTime.Caption    := QueryTime(True); //Not to forget to re-
  //enable this code
  FreeConsole;
end;

procedure TMultiForm.btnPackClick(Sender: TObject);
begin
  if ((lblDir.Caption = TranslateMsg('N/A')) or (lblDir.Caption = '')) or
    (length(FFiles) < 1) then
  begin
    ShowMessage(TranslateMsg('No directory selected'));
    Exit;
  end;
  Active := True;
  EnableButtons(False);
  PackFiles;
  EnableButtons(True);
  Active := False;
end;

procedure TMultiForm.FormActivate(Sender: TObject);
begin
  TranslateForm(MultiForm);
  if GlobFileName <> '' then
  begin
    lblDir.Caption := ExtractFileDir(GlobFileName);
  end;
  cmbType.ItemIndex := 0;
  lvFiles.Columns[0].Caption := TranslateMsg('File Name');
  lvFiles.Columns[1].Caption := TranslateMsg('Folder');
  lvFiles.Columns[2].Caption := TranslateMsg('Size');
  lvFiles.Columns[3].Caption := TranslateMsg('Packed');
  lvFiles.Columns[4].Caption := TranslateMsg('Result');
end;

procedure TMultiForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  GlobFileName := FGlobFileName;
end;

procedure TMultiForm.lvFilesKeyUp(Sender: TObject; var Key: word;
  Shift: TShiftState);
begin
  if (Key = VK_DELETE) and ( not Active) and (lvFiles.Selected <> nil) then
  begin
    if lvFiles.Selected.SubItems[3] = TranslateMsg('Skip') then
    begin
      lvFiles.Selected.SubItems[3] := '---';
      FFiles[lvFiles.Selected.Index].Skip := False;
    end
    else begin
      lvFiles.Selected.SubItems[3] := TranslateMsg('Skip');
      FFiles[lvFiles.Selected.Index].Skip := True;
    end;
  end;
end;

procedure TMultiForm.lvFilesMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: integer);
begin
  if (Button = mbRight) and ( not Active) and (lvFiles.Selected <> nil) then
  begin
    if lvFiles.Selected.SubItems[3] = TranslateMsg('Skip') then
    begin
      lvFiles.Selected.SubItems[3] := '---';
      FFiles[lvFiles.Selected.Index].Skip := False;
    end
    else begin
      lvFiles.Selected.SubItems[3] := TranslateMsg('Skip');
      FFiles[lvFiles.Selected.Index].Skip := True;
    end;
  end;
end;

end.