unit ExtractorMain;
{$DEFINE USE_DZIP_UNPACK}
// todo: compilerswitch, der auch selectdirectory() anzeigt (ohne foldercreate)
interface
uses
Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ShellAPI,
ExtCtrls, ComCtrls, ZipMstr19, ZMMsgStr19, ZMMsg19, ZMDelZip19,
ZMCompat19, SFXBehavior, ShlObj;
type
TOverwriteDecision = (odUndefined, odOverwriteAll, odOverwriteNothing);
TMainForm = class(TForm)
ProgressBar: TProgressBar;
WaitLabel: TLabel;
CancelBtn: TButton;
CurrentFileLabel: TLabel;
AutoTimer: TTimer;
itemBar: TProgressBar;
procedure CancelBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure AutoTimerTimer(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
RenamingOldPrefix: string;
RenamingNewPrefix: string;
zb: TZIPBehavior;
BaseDir: string;
AbortUnzip: boolean;
StopAskingPassword: boolean;
LastTriedPassword: string;
OverwriteDecision: TOverwriteDecision;
{$IFNDEF USE_DZIP_UNPACK}
procedure ExtractDllFromResource(ADirectory: string);
{$ENDIF}
procedure ExtractZipHere(AZipfile: string);
procedure ArcExtFNChange(Sender: TObject; var FileName: TZMString; const BaseDir: TZMString; var IsChanged: Boolean);
procedure ArcProzess(Sender: TObject; details: TZMProgressDetails);
procedure ArcTick(Sender: TObject);
procedure ArcCheckTerminate(Sender: TObject; var abort: Boolean);
procedure ConfirmOverwrite(Sender: TObject; const ForFile: TZMString;
IsOlder: Boolean; var DoOverwrite: Boolean; DirIndex: Integer);
procedure ArcPassword(Sender: TObject; IsZipAction: Boolean;
var NewPassword: String; const ForFile: TZMString; var RepeatCount: Longword;
var Action: TMsgDlgBtn);
procedure SkipEvent(Sender: TObject; const ForFile: TZMString;
SkipType: TZMSkipTypes; var ExtError: Integer);
function StripBaseDir(const s: string): string;
end;
var
MainForm: TMainForm;
implementation
uses
ExtractorPassword, ExtractorError, Functions, SFXAutoRun, ExtractorComment;
const
MaxTries = 15;
{$R *.dfm}
{$R zmstr1900102\DLL\ResDLL-Maker\ZMRes19_dll.res}
function IsRootFile(s: string): boolean;
var
i: integer;
begin
if s = '' then
begin
result := false;
Exit;
end;
if LooksLikeDir(s) then
begin
s := Copy(s, 1, Length(s)-1);
end;
for i := 1 to Length(s) do
begin
if s[i] = PathDelim then
begin
result := false;
Exit;
end;
end;
result := true;
end;
function FEListAll(theRec: TZMDirEntry; var Data): Integer;
var
l: TStringList absolute Data;
s: string;
begin
Result := 0;
s := theRec.FileName;
l.Add(s);
s := ExtractFilePath(s);
if l.IndexOf(s) = -1 then l.Add(s);
end;
procedure ListRootFiles(uz: TZipMaster19; List: TStringList);
var
s: string;
l: TStringList;
i: Integer;
resourcestring
Lng_ForeachFailed = 'Dateiiteration fehlgeschlagen!';
begin
List.Clear;
l := TStringList.Create;
try
// Fill list (inclusive Directories)
uz.FSpecArgs.Add('*');
if uz.ForEach(FEListAll, l) <> 0 then
begin
MessageDlg(Lng_ForeachFailed, mtError, [mbOk], 0);
end;
// Now look for root files
for i := 0 to l.Count - 1 do
begin
s := l.Strings[i];
if IsRootFile(s) then
begin
List.Add(s);
end;
end;
finally
l.Free;
end;
end;
procedure TMainForm.ExtractZipHere(AZipfile: string);
var
uz: TZipMaster19;
l: TStringList;
s: string;
ec: Integer;
ar: TExecuteSFXAutoRunResult;
GeneralBaseDir: string;
resourcestring
Lng_Aborted = 'Der laufende Prozess wurde abgebrochen. Das extrahierten Dateien sind somit unvollständig.';
Lng_Zip_Error = 'ZIP-Master Fehler "%s" (%d)';
Lng_AutoRunFailed = 'SFX-AutoRun fehlgeschlagen. Die entpackten Inhalte werden nun angezeigt.';
Lng_Unknown_Error = 'Unbekannter Fehler: Dateien sind nicht aufzufinden!';
Lng_SelectDir = 'Bitte wählen Sie ein Verzeichnis zum Extrahieren aus. Es wird maximal 1 Datei bzw. Ordner erstellt!';
begin
AZipfile := ExpandUNCFileName(AZipfile);
RenamingOldPrefix := '';
RenamingNewPrefix := '';
uz := TZipMaster19.Create(nil);
try
{$IFNDEF USE_DZIP_UNPACK}
uz.DLLDirectory := GetTempDirectory + DelZipDLL_Name;
{$ENDIF}
uz.DLL_Load := true;
uz.ZipFileName := AZipFile;
uz.Active := true;
zb := ReadBehavior(uz.ZipComment);
uz.Unattended := true;
uz.ExtrOptions := [ExtrDirNames, ExtrOverWrite, ExtrFreshen, ExtrUpdate,
ExtrForceDirs, ExtrNTFS];
if zb.ConflictBehavior <> cbAvoid then
begin
uz.OnExtractOverwrite := ConfirmOverwrite;
end;
uz.OnProgress := ArcProzess;
uz.OnTick := ArcTick;
uz.OnCheckTerminate := ArcCheckTerminate;
uz.OnPasswordError := ArcPassword;
uz.PasswordReqCount := MaxTries;
uz.OnSkipped := SkipEvent;
uz.OnSetExtName := ArcExtFNChange;
// TODO: Mehr events?
// Find out base dirtory
GeneralBaseDir := '';
case zb.ExtractionTarget of
etExtractHere:
begin
GeneralBaseDir := ExtractFilePath(AZipfile); // Default
end;
etDesktop:
begin
GeneralBaseDir := GetSpecialFolderPath(CSIDL_DESKTOP);
end;
etAsk:
begin
if not AdvSelectDirectory(Lng_SelectDir, '', GeneralBaseDir, False, False, True) then
begin
Exit;
end;
end;
end;
GeneralBaseDir := IncludeTrailingPathDelimiter(GeneralBaseDir);
// Semantic scanning of ZIP to determinate the final extraction directory
l := TStringList.Create;
try
// Count the root objects (files OR dirs) in the ZIP
ListRootFiles(uz, l);
if l.Count = 0 then
begin
// Empty ZIP or Extractor.exe was called without ZIP attached
Exit;
end
else if l.Count = 1 then
begin
// 1 Object = Extract it right here!
BaseDir := GeneralBaseDir;
s := BaseDir + l.Strings[0];
RenamingOldPrefix := l.Strings[0]; // = StripBaseDir(S);
if zb.ConflictBehavior = cbAvoid then
begin
s := SearchNextFreeName(s, LooksLikeDir(s));
end;
RenamingNewPrefix := StripBaseDir(s);
end
else
begin
// 2+ Objects = Extract them in a separate folder
s := GeneralBaseDir + ExtractFileNameWithoutExt(AZipfile) + PathDelim;
if zb.ConflictBehavior = cbAvoid then
begin
s := SearchNextFreeName(s, true);
MkDir(s);
end
else
begin
if not DirectoryExists(s) then MkDir(s);
end;
BaseDir := s;
end;
BaseDir := IncludeTrailingPathDelimiter(BaseDir);
uz.ExtrBaseDir := BaseDir;
// Pre-Extract-Dialog
if zb.CommentPresentation = cpBeforeExtracting then
begin
if not CommentForm.ShowCommentModal(uz.ZipComment) then exit;
end;
// Extract
ec := uz.Extract;
if ec <> 0 then
begin
if ec = DS_Canceled then
begin
MessageDlg(Lng_Aborted, mtWarning, [mbOk], 0);
end
else
begin
MessageDlg(Format(Lng_Zip_Error, [uz.ErrMessage, ec]), mtError, [mbOk], 0);
end;
end;
// Errors?
if ErrorForm.ErrorsAvailable then
begin
ErrorForm.ShowModal;
end;
// Show After-Extracting comment?
if zb.CommentPresentation = cpAfterExtracting then
begin
if not CommentForm.ShowCommentModal(uz.ZipComment) then exit;
end;
// Now search for an AutoRun.inf
ar := ExecuteSFXAutoRun(BaseDir);
if ar.AutoRunSectionAvailable and not ar.ExecutionSucceed then
begin
MessageDlg(Lng_AutoRunFailed, mtError, [mbOk], 0);
ar.OpenUnzippedContent := true;
end;
// Now open the file for the user
if not ar.AutoRunSectionAvailable or ar.OpenUnzippedContent then
begin
if DirectoryExists(s) then
begin
// If it is a folder, open it
ShellExecute(0, 'open', 'explorer',
PChar('"'+s+'"'), '', SW_NORMAL);
end
else if FileExists(s) then
begin
// If it is a file, then only select it
// Que: Funktioniert das auch ohne "/n"?
// Im Moment wird bei einem BESTEHENDEN Fenster
// die Selektion nicht durchgeführt.
ShellExecute(0, 'open', 'explorer',
PChar('/n,/select,"'+s+'"'), '', SW_NORMAL);
end
else
begin
MessageDlg(Lng_Unknown_Error, mtError, [mbOk], 0);
end;
end;
finally
l.Free;
end;
finally
uz.Free;
end;
end;
procedure TMainForm.ArcProzess(Sender: TObject; details: TZMProgressDetails);
begin
CurrentFileLabel.Caption := details.ItemName;
progressBar.Position := details.TotalPosition;
progressBar.Max := details.TotalSize;
itemBar.Position := details.ItemPosition;
itemBar.Max := details.ItemSize;
Application.ProcessMessages;
end;
procedure TMainForm.ArcExtFNChange(Sender: TObject;
var FileName: TZMString; const BaseDir: TZMString;
var IsChanged: Boolean);
begin
if RenamingOldPrefix = RenamingNewPrefix then Exit;
FileName := RenamingNewPrefix + Copy(FileName, 1+Length(RenamingOldPrefix), Length(FileName)-Length(RenamingOldPrefix));
IsChanged := true;
end;
procedure TMainForm.ArcTick(Sender: TObject);
begin
Application.ProcessMessages;
end;
procedure TMainForm.ArcCheckTerminate(Sender: TObject; var abort: Boolean);
begin
abort := AbortUnzip;
end;
procedure TMainForm.ConfirmOverwrite(Sender: TObject; const ForFile: TZMString;
IsOlder: Boolean; var DoOverwrite: Boolean; DirIndex: Integer);
resourcestring
Lng_Overwrite = 'Bestehende Datei "%s" überschreiben?';
var
res: Integer;
begin
if zb.ConflictBehavior = cbOverwrite then
begin
DoOverwrite := true;
Exit;
end
else if zb.ConflictBehavior = cbNewer then
begin
DoOverwrite := IsOlder; // If file on DISK is older, then overwrite.
Exit;
end
else if zb.ConflictBehavior = cbAsk then
begin
// Workaround: Verzeichnisse brauchen das nicht,
// denn es wird bei den Dateien nochmal nachgefragt
if LooksLikeDir(ForFile) then
begin
DoOverwrite := true;
Exit;
end;
if OverwriteDecision = odUndefined then
begin
res := MessageDlg(Format(Lng_Overwrite, [ForFile]), mtConfirmation, [mbYes, mbNo, mbYesToAll, mbNoToAll], 0);
DoOverwrite := (res = mrYes) or (res = mrYesToAll);
if res = mrNoToAll then OverwriteDecision := odOverwriteNothing;
if res = mrYesToAll then OverwriteDecision := odOverwriteAll;
end
else
begin
DoOverwrite := OverwriteDecision = odOverwriteAll;
end;
end;
end;
procedure TMainForm.ArcPassword(Sender: TObject; IsZipAction: Boolean;
var NewPassword: String; const ForFile: TZMString; var RepeatCount: Longword;
var Action: TMsgDlgBtn);
var
repc: integer;
begin
repc := MaxTries - RepeatCount + 1;
// Eine Passworteingabe wurde abgebrochen. Frage nicht mehr nach.
if StopAskingPassword then Exit;
// Wurde schonmal ein Passwort eingegeben?
if LastTriedPassword <> '' then
begin
// Schauen, ob das letzte Passwort auch mit dieser Datei geht.
if repc = 1 then
begin
// Ja, geht
NewPassword := LastTriedPassword;
Exit;
end
else
begin
// Leider nein
LastTriedPassword := '';
end;
end;
if PasswordDlg.ShowModal(StripBaseDir(ForFile), repc, MaxTries) = mrOk then
begin
NewPassword := PasswordDlg.Password.Text;
if NewPassword = '' then NewPassword := ' '; // Neue Eingabe erzwingen.
LastTriedPassword := NewPassword;
end
else
begin
StopAskingPassword := true;
Action := mbCancel;
end;
end;
procedure TMainForm.CancelBtnClick(Sender: TObject);
resourcestring
Lng_AbortExtract = 'Extrahieren abbrechen?';
begin
if MessageDlg(Lng_AbortExtract, mtConfirmation, mbYesNoCancel, 0) = mrYes then
begin
CancelBtn.Enabled := false;
AbortUnzip := true;
end;
end;
procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if not AbortUnzip then
begin
CancelBtn.Click;
CanClose := false;
end;
end;
procedure TMainForm.FormCreate(Sender: TObject);
resourcestring
Lng_Extracting = 'Extrahiere Dateien. Bitte warten...';
begin
WaitLabel.Caption := Lng_Extracting;
WaitLabel.Left := progressBar.Width div 2 - WaitLabel.Width div 2;
CurrentFileLabel.Caption := '';
end;
{$IFNDEF USE_DZIP_UNPACK}
procedure TMainForm.ExtractDllFromResource(ADirectory: string);
var
s: TResourceStream;
o: TFileStream;
AOutFile: string;
begin
AOutFile := IncludeTrailingPathDelimiter(ADirectory) + DelZipDLL_Name;
s := TResourceStream.Create(0, DZRES_Dll, RT_RCDATA);
try
try
s.Seek(SizeOf(Integer), soFromBeginning); // Ref: ZMDllLoad19.pas:427
if FileExists(AOutFile) then
o := TFileStream.Create(AOutFile, fmOpenWrite or fmShareDenyNone)
else
o := TFileStream.Create(AOutFile, fmCreate or fmShareDenyNone);
try
o.CopyFrom(s, s.Size-s.Position);
finally
o.Free;
end;
except
if FileExists(AOutFile) then
begin
// Probably the file is write-locked (maybe some other Extractor is
// using it right now? Even if we run into danger that the target DLL
// is a write-protected old/incompatible version of DelZip190.dll,
// we do count this as success, since the file exists.
end
else
begin
raise;
end;
end;
finally
s.Free;
end;
end;
{$ENDIF}
procedure TMainForm.AutoTimerTimer(Sender: TObject);
resourcestring
Lng_NakedSFX = 'Das selbstentpackende Archiv (SFX) beschädigt oder ungültig. Wenn Sie diese Datei aus dem Internet bezogen haben, laden Sie sie bitte erneut herunter.';
Lng_FileNotFound = 'Die durch Parameter angegebene Datei "%s" kann nicht gefunden werden!';
Lng_TooManyArguments = 'Zu viele Argumente!';
begin
AutoTimer.Enabled := false;
{$IFNDEF USE_DZIP_UNPACK}
ExtractDllFromResource(GetTempDirectory);
{$ENDIF}
try
if IsExtractable(ParamStr(0)) then
begin
ExtractZipHere(ParamStr(0));
end
else
begin
// Der Extractor ist "nackt" oder das SFX beschädigt
if ParamCount = 0 then
begin
MessageDlg(Lng_NakedSFX, mtError, [mbOk], 0);
end
else if ParamCount = 1 then
begin
// In diesem Zustand erlauben wir, fremde SFX zu entpacken (auch für Debugging-Zwecke)
if FileExists(ParamStr(1)) then
begin
ExtractZipHere(ParamStr(1));
end
else
begin
MessageDlg(Lng_FileNotFound, mtError, [mbOk], 0);
end;
end
else if ParamCount = 2 then
begin
// Future: Mehr als nur 1 Parameter erlauben?
MessageDlg(Lng_TooManyArguments, mtError, [mbOk], 0);
end;
end;
finally
AbortUnzip := true; // Damit es zu keiner Abfrage in OnCloseQuery kommt
Close;
end;
end;
function TMainForm.StripBaseDir(const s: string): string;
begin
// Warnung: Es wird nicht überprüft, ob der String auch
// wirklich mit dem BaseDir beginnt!
result := Copy(s, Length(BaseDir)+1, Length(s)-Length(BaseDir));
end;
procedure TMainForm.SkipEvent(Sender: TObject; const ForFile: TZMString;
SkipType: TZMSkipTypes; var ExtError: Integer);
resourcestring
Lng_PasswordWrong = 'Das Passwort wurde zu oft falsch eingegeben. Die Datei "%s" wird nicht extrahiert.';
begin
if (SkipType = stBadPassword) and not StopAskingPassword then
begin
MessageDlg(Format(Lng_PasswordWrong, [ForFile]), mtError, [mbOk], 0);
LastTriedPassword := '';
end;
ErrorForm.NewError(StripBaseDir(ForFile));
end;
end.