mainfrm.pas

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

  end;
end;
// Scans workdir for .lng files and adds them to cmbLanguage
procedure EnumerateLanguages;
//Kill the final .lng extension to show in the cmbLanguage
  function KillExt(const FullPath: string): string;
  begin
    Result := ExtractFileName(FullPath);
    Result := copy(Result, 1, pos('.', Result) - 1);
  end;

var
  SRec:  TSearchRec;
  LangF: string;
begin
  SetCurrentDir(WorkDir);
  if FindFirst('*.lng', faAnyFile, SRec) = 0 then
  begin
    MainForm.cmbLanguage.Items.Add(KillExt(SRec.Name));
    while FindNext(SRec) = 0 do
    begin
      MainForm.cmbLanguage.Items.Add(KillExt(SRec.Name));
    end;
  end;
  FindClose(SRec);
  with MainForm.cmbLanguage do
  begin
    LangF := ReadKey('LanguageFile', ktString).Str;
    if LangF = '' then
    begin
      ItemIndex := Items.IndexOf('English');
      LangFile  := 'English';
    end
    else begin
      ItemIndex := Items.IndexOf(LangF);
      LangFile  := LangF;
    end;
  end;
end;

procedure StartScramble;
begin
  ScrambleUPX();
end;

procedure StartCompression; //initializes compression
var
  StartTime: int64;
  CompressParams: string;
  Compress:  TCompDecomp; //Holds whether to compress or decompress
  OldCursor: TCursor;
  // This one gets the compression time
  procedure StartTimer;
  begin
    QueryPerformanceCounter(StartTime);
  end;

  function StopTimer: string;
  var
    Frequency, StopTime: int64;
    Time: string[5];
  begin
    QueryPerformanceFrequency(Frequency);
    QueryPerformanceCounter(StopTime);
    Time   := floattostr((StopTime - StartTime) / Frequency);
    Result := Time;
  end;

  procedure SetCompressionVisuals(ControlEnabled: boolean);
  begin
    with MainForm do
    begin
      btnOpen.Enabled    := ControlEnabled;
      btnGo.Enabled      := ControlEnabled;
      imgHistory.Enabled := ControlEnabled;
      chkDecomp.Enabled := ControlEnabled;
      if ControlEnabled then
      begin
        if Compress <> cdCompress then
        begin
          chkUPX1.Enabled := ControlEnabled;
          chkUPX2.Enabled := ControlEnabled;
        end;
      end
      else begin
        chkUPX1.Enabled := ControlEnabled;
        chkUPX2.Enabled := ControlEnabled;
      end;
      btnRun.Enabled      := ControlEnabled;
      chkBackup.Enabled   := ControlEnabled;
      chkAutoCompress.Enabled := ControlEnabled;
      chkExitDone.Enabled := ControlEnabled;
      chkTest.Enabled     := ControlEnabled;
      btnAdvanced.Enabled := ControlEnabled;
      btnMultiPck.Enabled := ControlEnabled;
      trbCompressLvl.Enabled := ControlEnabled;
      if not ControlEnabled then
      begin
        sttDecomp.Width := 0;
      end;
    end;
  end;

  procedure TouchFile(const FileName: string);
  begin
    SHChangeNotify(SHCNE_UPDATEITEM, SHCNF_PATH, PChar(FileName), nil);
    SHChangeNotify(SHCNE_ATTRIBUTES, SHCNF_PATH, PChar(ExtractFileDir(FileName)), nil); //SHCNE_UPDATEDIR - SHCNE_ATTRIBUTES
  end;

  //Main code
begin
  Busy      := True;
  OldCursor := Screen.Cursor;
  try
    StartTimer;
    DragAcceptFiles(MainForm.Handle, False);
    //Disable Drag&Drop while compressing
    CompressParams := GetCompressParams;
    SetCompressionVisuals(False);
    if not MainForm.chkDecomp.Checked then
    begin
      Compress := cdCompress;
    end
    else begin
      Compress := cdDecompress;
    end;
    //Start the compression now
    CompressFile(CompressParams, Compress);
    SetCompressionVisuals(True);
    MainForm.stbMain.Panels[1].Text := MainForm.stbMain.Panels[1].Text +
      TranslateMsg(' (in ') + StopTimer + TranslateMsg(' seconds)');
    if (Compress = cdCompress) and (SetupForm.chkScramble.Checked) then
    begin
      try
        Screen.Cursor := crHourGlass;
        StartScramble;
      finally
        Screen.Cursor := OldCursor;
      end;
    end;
    TouchFile(GlobFileName);
    if (MainForm.chkExitDone.Checked) and (CompressionResult) then
    begin
      Application.Terminate;
    end;
  finally
    Busy := False;
    DragAcceptFiles(MainForm.Handle, True); // Re-enable Drag&Drop
  end;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  DrawGradient(imgGradient.Canvas, 255, imgGradient.Height,
    imgGradient.Width, clSilver, GetSysColor(COLOR_BTNFACE));
  DragAcceptFiles(MainForm.Handle, True); // Enable Drag&Drop
  with Globals.Config do
  begin
    DebugMode := False;
    LocalizerMode := False;
  end;
  LoadSettings;
  LoadHistory;
  ParseCommandLine;
  Application.HintHidePause := 10000;
  Application.HelpFile      := WorkDir + 'UPXShell.chm';
  EnumerateLanguages;
  // Scans for available language files and adds to cmbLanguage
  DrawGradient(imgLogoGrad1.Canvas, 50, imgLogoGrad1.Height,
    imgLogoGrad1.Width,
    clBtnFace, clSilver);
  DrawGradient(imgLogoGrad2.Canvas, 50, imgLogoGrad2.Height,
    imgLogoGrad2.Width,
    clSilver, clBtnFace);
end;
// Clears the History menu
procedure TMainForm.ClearHistoryClick(Sender: TObject);
var
  Value: TRegValue;
  i:     integer;
begin
  Value.Str := '';
  StoreKey('History', Value, ktString);
  for i := mnuHistory.Items.Count - 1 downto 2 do
  begin
    mnuHistory.Items.Delete(i);
  end;
end;

procedure TMainForm.imgHistoryMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: integer);
begin
  mnuHistory.Popup(MainForm.Left + 90, MainForm.Top + 200);
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  SaveSettings;
end;

procedure TMainForm.btnOpenClick(Sender: TObject);
var
  val: TRegValue;
begin
  dlgOpen.FilterIndex := Extension;
  with ReadKey('LastFolder', ktString) do
  begin
    if Str <> '' then
    begin
      dlgOpen.InitialDir := Str;
    end;
  end;
  if dlgOpen.Execute then
  begin
    Extension := dlgOpen.FilterIndex;
    val.Str   := ExtractFileDir(dlgOpen.FileName);
    StoreKey('LastFolder', val, ktString);
    if dlgOpen.FileName <> '' then
    begin
      LoadFile(dlgOpen.filename);
    end;
  end;
end;

procedure TMainForm.btnGoClick(Sender: TObject);
var
  CompDecomp: string;
begin
  if GlobFileName = '' then
  begin
    if chkDecomp.Checked then
    begin
      CompDecomp := TranslateMsg('decompress');
    end
    else begin
      CompDecomp := TranslateMsg('compress');
    end;
    beep;
    Application.MessageBox(PChar(TranslateMsg('There is nothing to ') +
      CompDecomp),
      TranslateMsg('Error'), MB_OK + MB_ICONERROR);
  end
  else begin
    StartCompression;
  end;
end;
//Drag&Drop handler
procedure TMainForm.WMDropfiles(var msg: Tmessage);
var
  hdrop:     integer; //THandle
  buffer:    string;
  buflength: integer;
begin
  hdrop     := msg.WParam;
  buflength := DragQueryFile(hdrop, 0, nil, 300) + 1;
  setlength(buffer, buflength);
  DragQueryFile(hdrop, 0, PChar(buffer), buflength);
  DragFinish(hdrop);
  LoadFile(trim(buffer));
end;

procedure TMainForm.tbsOpenShow(Sender: TObject);
begin
  if btnOpen.Enabled then
  begin
    btnOpen.SetFocus;
  end;
end;

procedure TMainForm.tbsCompressShow(Sender: TObject);
begin
  if btnGo.Enabled then
  begin
    btnGo.SetFocus;
  end;
end;

procedure TMainForm.tbsOptionsShow(Sender: TObject);
begin
  if chkBackup.Enabled then
  begin
    chkBackup.SetFocus;
  end;
end;

procedure TMainForm.tbsAboutShow(Sender: TObject);
begin
  if pnlAbout.Enabled then
  begin
    pnlAbout.SetFocus;
  end;
end;

procedure TMainForm.tbsHelpShow(Sender: TObject);
begin
  if btnHelp.Enabled then
  begin
    btnHelp.SetFocus;
  end;
end;

procedure TMainForm.trbCompressLvlChange(Sender: TObject);
begin
  TrackBest;
end;

procedure TMainForm.btnAdvancedClick(Sender: TObject);
begin
  SetupForm.ShowModal;
end;

procedure TMainForm.cmbLanguageChange(Sender: TObject);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CURRENT_USER;
    reg.OpenKey('Software\ION Tek\UPX Shell\3.x', True);
    reg.WriteString('OldContext', Trim(TranslateMsg('Compress with UPX')));
    reg.CloseKey;
  finally
    FreeAndNil(reg);
  end;
  LangFile := cmbLanguage.Text;
  LoadLanguage(MainForm);
  TrackBest;
  IntergrateContext(True);  
end;

procedure TMainForm.FormActivate(Sender: TObject);
begin
  LoadLanguage(MainForm);
  TrackBest; //Checks the position of CompressionLevel TrackBar
  LoadVisualSettings;
end;

procedure TMainForm.stbMainMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: integer);
begin
  if (stbMain.Panels[0].Text <> '') and (stbMain.Panels[1].Text = '') then
  begin
    stbMain.Hint := stbMain.Panels[0].Text;
  end
  else begin
    if (stbMain.Panels[0].Text <> '') and (stbMain.Panels[1].Text <> '') then
    begin
      stbMain.Hint := stbMain.Panels[0].Text + #13#10 + stbMain.Panels[1].Text;
    end;
  end;
end;

procedure TMainForm.btnHelpClick(Sender: TObject);
begin
  ShellExecute(self.Handle, 'open', PChar(Application.HelpFile), nil,
    nil, SW_SHOWNORMAL);
end;

procedure TMainForm.btnMultiPckClick(Sender: TObject);
begin
  MultiForm := TMultiForm.Create(self);
  try
    // 1: Fix by KIRILL on 12.03.2003
    MainForm.Hide;
    MultiForm.ShowModal;
    MainForm.Show;
  finally
    MultiForm.Release
  end;
end;

procedure TMainForm.StdUPXVersionClick(Sender: TObject);
begin
  case (Sender as TRadioButton).Tag of
    1:
    begin
      bStdUPXVersion := 1;
    end;
    2:
    begin
      bStdUPXVersion := 2;
    end;
  end;
end;

procedure TMainForm.btnRunClick(Sender: TObject);
begin
  ShellExecute(self.Handle, 'open', PChar(GlobFileName), nil, nil,
    SW_SHOWNORMAL);
end;

procedure TMainForm.HyperClick(Sender: TObject);
var
  s: string;
begin
  // 1: Fix by KIRILL on 12.03.2003
  case (Sender as TLabel).Tag of
    1:
    begin
      S := 'http://upxshell.sf.net';
    end;
    2:
    begin
      S := 'http://upx.sf.net';
    end;
    3:
    begin
      S := 'mailto:ION_T<[e-mail]>?Subject=UPX_Shell_' +
        GetBuild(biFull);
    end;
    4:
    begin
      S := 'mailto:BlackDex<[e-mail]>?Subject=UPX_Shell_' +
        GetBuild(biFull);
    end;
    5:
    begin
      S := 'mailto:Blaine<[e-mail]>?Subject=UPX_Shell_' +
        GetBuild(biFull);
    end;
  end;
  ShellExecute(0, 'open', PChar(s), nil, nil, SW_SHOWNORMAL);
end;

procedure TMainForm.FormShow(Sender: TObject);
begin
  // I have no other choice, but to put this code in the
  // onShow event, since I must make sure that the form is
  // drawn...
  if lowercase(ParamStr(1)) <> '' then
  begin
    //Checks if there's a file passed through command line
    LoadFile(ParamStr(1));
  end;
  OnShow := nil;
end;

procedure TMainForm.UPXVersionClick(Sender: TObject);
begin
  case (Sender as TRadioButton).Tag of
    1:
    begin
      bStdUPXVersion := 1;
    end;
    2:
    begin
      bStdUPXVersion := 2;
    end;
  end;
end;

procedure TMainForm.btnChkUpdateClick(Sender: TObject);

  //Inline function to get the update file
  function GetInetFile(const fileURL: string; strStream: TStringStream): boolean;
  const
    BufferSize = 1024;
  var
    hSession: HInternet;
    hURL: HInternet;
    Buffer: array[1..BufferSize] of Byte;
    BufferLen: DWORD;
    sAppName: string;
  begin
    sAppName := ExtractFileName(Application.ExeName);
    hSession := InternetOpen(PChar(sAppName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
    try
      hURL := InternetOpenURL(hSession, PChar(fileURL), nil,0,0,0);
      try
        repeat
        begin
          InternetReadFile(hURL, @Buffer, SizeOf(Buffer), BufferLen);
          strStream.WriteBuffer(Buffer, BufferLen);
        end;
        until BufferLen = 0;
        Result := true;
      finally
        InternetCloseHandle(hURL)
      end;
    finally
      InternetCloseHandle(hSession)
    end;
  end;

//Main procedure
var
  sUpdateFile: string;
  sInetStream: TStringStream;
  sInetStrings: TStrings;
  OldCursor: TCursor;
begin
 sUpdateFile:= 'http://upxshell.sf.net/update/update.upd';

 sInetStream := TStringStream.Create('');
 sInetStrings := TStringList.Create;
 rchChangeLog.Lines.Clear;
 OldCursor := screen.Cursor;
 try
   Screen.Cursor := crHourGlass;
   if GetInetFile(sUpdateFile, sInetStream) then
   begin
     sInetStrings.Clear;
     sInetStrings.Delimiter := '=';
     sInetStrings.QuoteChar := '"';
     sInetStrings.DelimitedText := sInetStream.DataString;

     if (sInetStrings[sInetStrings.IndexOf('UPDATEFILE') + 1] = 'UPXSHELL') then
     begin
       lblOnlineVersion.Caption := sInetStrings[sInetStrings.IndexOf('release') + 1] + '.' + sInetStrings[sInetStrings.IndexOf('build') + 1];
       lblReleaseDate.Caption := sInetStrings[sInetStrings.IndexOf('date') + 1];

       if (sInetStrings[sInetStrings.IndexOf('build') + 1] > GetBuild(biBuild)) or
          (sInetStrings[sInetStrings.IndexOf('release') + 1] > GetBuild(biNoBuild)) then
          begin
            lblDownload.Caption := sInetStrings[sInetStrings.IndexOf('url') + 1];
            lblDownload.Font.Color := clBlue;
            lblDownload.Enabled := true;
            rchChangeLog.Lines.Add(sInetStrings[sInetStrings.IndexOf('changelog') + 1]);
          end
          else
          begin
            rchChangeLog.Lines.Add('There is no new update avalable.');
            lblDownload.Font.Color := clWindowText;
            lblDownload.Enabled := false;
          end;
     end
     else
       rchChangeLog.Lines.Add('Error retereving updates!' + #13#10 + 'Invalide or missing update file.');
     begin
     end;
   end
   else
   begin
     rchChangeLog.Lines.Add('Error retereving updates!');
   end;
 finally
  Screen.Cursor := OldCursor;
  FreeAndNil(sInetStream);
  FreeAndNil(sInetStrings);
  FreeAndNil(OldCursor);
 end;
end;

procedure TMainForm.lblDownloadClick(Sender: TObject);
begin
  if lblDownload.Enabled then
  begin
    ShellExecute(0, 'open', PChar(lblDownload.Caption), Nil, Nil, SW_SHOW);
  end;
end;

(*
procedure TMainForm.btnLocalizerModeClick(Sender: TObject);
begin
  // Toggle localization mode
  // In this mode every object capable of MouseUp event
  // detection get's a popup menu, which allows one to set
  // the object's caption and hint
  Globals.Config.LocalizerMode := not Globals.Config.LocalizerMode;
  pnlLocalization.Visible := Globals.Config.LocalizerMode;
  LocalizerMode(self, Globals.Config.LocalizerMode);
end;
*)

end.