WebSVN – autosfx – Path Comparison – /

Regard whitespace Rev 1 → Rev 2

/Icon.ico
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Deleted: svn:mime-type
-application/octet-stream
\ No newline at end of property

 /ExtractorMain.pas
 ,10 → 1,8
 unit ExtractorMain;
-{$DEFINE DEBUG_MODE}
 {$DEFINE USE_DZIP_UNPACK}
-// TODO: Implement ExtractionTarget switch
+// todo: compilerswitch, der auch selectdirectory() anzeigt (ohne foldercreate)
 interface
 ,7 → 9,7
 uses
   Windows, SysUtils, Classes, Controls, Forms, Dialogs, StdCtrls, ShellAPI,
   ExtCtrls, ComCtrls, ZipMstr19, ZMMsgStr19, ZMMsg19, ZMDelZip19,
-  ZMCompat19, SFXBehavior;
+  ZMCompat19, SFXBehavior, ShlObj;
 type
   TOverwriteDecision = (odUndefined, odOverwriteAll, odOverwriteNothing);
 ,11 → 148,13
   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 := '';
 ,10 → 184,34
     uz.OnCheckTerminate := ArcCheckTerminate;
     uz.OnPasswordError := ArcPassword;
     uz.PasswordReqCount := MaxTries;
-    // TODO: Mehr events?
     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
 ,23 → 226,25
       else if l.Count = 1 then
       begin
         // 1 Object = Extract it right here!
-        s := ExtractFilePath(AZipfile) + l.Strings[0];
-        BaseDir := ExtractFilePath(AZipfile);
-        RenamingOldPrefix := StripBaseDir(S);
+        BaseDir := GeneralBaseDir;
+        s := BaseDir + l.Strings[0];
+        RenamingOldPrefix := l.Strings[0]; // = StripBaseDir(S);
         if zb.ConflictBehavior = cbAvoid then
         begin
-          s := SearchNextFreeName(s);
+          s := SearchNextFreeName(s, LooksLikeDir(s));
         end;
-        // TODO: helloworld.exe schlägt fehl!
-        RenamingNewPrefix := StripBaseDir(S); // We need to change the name!
+        RenamingNewPrefix := StripBaseDir(s);
       end
       else
       begin
         // 2+ Objects = Extract them in a separate folder
-        s := ChangeFileExt(AZipfile, '');
+        s := GeneralBaseDir + ExtractFileNameWithoutExt(AZipfile) + PathDelim;
         if zb.ConflictBehavior = cbAvoid then
         begin
-          s := SearchNextFreeName(s);
+          s := SearchNextFreeName(s, true);
           MkDir(s);
         end
         else
 ,7 → 255,7
       end;
       BaseDir := IncludeTrailingPathDelimiter(BaseDir);
-      uz.ExtrBaseDir := BaseDir; // TODO: andere ordner erlauben
+      uz.ExtrBaseDir := BaseDir;
       // Pre-Extract-Dialog
 ,8 → 355,7
   var FileName: TZMString; const BaseDir: TZMString;
   var IsChanged: Boolean);
 begin
-  if RenamingOldPrefix = RenamingOldPrefix then Exit;
+  if RenamingOldPrefix = RenamingNewPrefix then Exit;
   FileName := RenamingNewPrefix + Copy(FileName, 1+Length(RenamingOldPrefix), Length(FileName)-Length(RenamingOldPrefix));
   IsChanged := true;
 end;
 ,9 → 476,6
 resourcestring
   Lng_Extracting = 'Extrahiere Dateien. Bitte warten...';
 begin
-  {$IFDEF DEBUG_MODE}
-  Caption := Caption + ' (Debug)';
-  {$ENDIF}
   WaitLabel.Caption := Lng_Extracting;
   WaitLabel.Left := progressBar.Width div 2 - WaitLabel.Width div 2;
   CurrentFileLabel.Caption := '';
 ,6 → 522,10
 {$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;
 ,7 → 534,21
   {$ENDIF}
   try
-    {$IFDEF DEBUG_MODE}
+    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));
 ,15 → 555,17
     end
     else
     begin
-    {$ENDIF}
-    ExtractZipHere(ParamStr(0));
-    {$IFDEF DEBUG_MODE}
+          MessageDlg(Lng_FileNotFound, mtError, [mbOk], 0);
     end;
-    {$ENDIF}
+      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 kommt
+    AbortUnzip := true; // Damit es zu keiner Abfrage in OnCloseQuery kommt
     Close;
   end;
 end;

 /SFXBehavior.pas
 ,7 → 41,7
   C_ASFX_ET_DES = 'AutoSFX Extraction Target: Extract to Desktop';
   C_ASFX_ET_ASK = 'AutoSFX Extraction Target: Choose directory';
-  EINRUECK      = '> '; // Optional
+  EINRUECK      = '> '; // Optional to all C_ASFX
 const
   CB_DEFAULT = cbAvoid;
 ,12 → 109,15
 function StripBehavior(c: string): string;
-  procedure StripIt(s: string);
+  procedure StripIt(s: string; allowEinrueck: boolean);
   begin
+    if allowEinrueck then
+    begin
     c := StringReplace(c, EINRUECK + s+#13#10, '', [rfReplaceAll, rfIgnoreCase]);
     c := StringReplace(c, EINRUECK + s+#13,    '', [rfReplaceAll, rfIgnoreCase]);
     c := StringReplace(c, EINRUECK + s+#10,    '', [rfReplaceAll, rfIgnoreCase]);
     c := StringReplace(c, EINRUECK + s,        '', [rfReplaceAll, rfIgnoreCase]);
+    end;
     c := StringReplace(c, s+#13#10, '', [rfReplaceAll, rfIgnoreCase]);
     c := StringReplace(c, s+#13,    '', [rfReplaceAll, rfIgnoreCase]);
 ,20 → 126,20
   end;
 begin
-  StripIt(C_SIGNATURE);
+  StripIt(C_SIGNATURE, false);
-  StripIt(C_ASFX_CB_AVO);
-  StripIt(C_ASFX_CB_OVR);
-  StripIt(C_ASFX_CB_NEW);
-  StripIt(C_ASFX_CB_ASK);
+  StripIt(C_ASFX_CB_AVO, true);
+  StripIt(C_ASFX_CB_OVR, true);
+  StripIt(C_ASFX_CB_NEW, true);
+  StripIt(C_ASFX_CB_ASK, true);
-  StripIt(C_ASFX_CP_NON);
-  StripIt(C_ASFX_CP_BEF);
-  StripIt(C_ASFX_CP_AFT);
+  StripIt(C_ASFX_CP_NON, true);
+  StripIt(C_ASFX_CP_BEF, true);
+  StripIt(C_ASFX_CP_AFT, true);
-  StripIt(C_ASFX_ET_HER);
-  StripIt(C_ASFX_ET_DES);
-  StripIt(C_ASFX_ET_ASK);
+  StripIt(C_ASFX_ET_HER, true);
+  StripIt(C_ASFX_ET_DES, true);
+  StripIt(C_ASFX_ET_ASK, true);
   result := c;
 end;

 /td.txt
 ,3 → 1,9
+- ein besseres win7 highres icon machen?
+- spanned sfx possible?
+test 2files, 1file, 1folder
+righttrim on commentwindow
 Delphi 6: Projekteinstellungen prüfen. Debugging bei Extractor aus
 Versioninfo für alle Projekte
 MakeSFX.ico auch in 16x16 (ref: cdfview.dll)

 /Functions.pas
 ,7 → 3,8
 interface
 uses
-  Windows, Classes, SysUtils, ShellAPI;
+  Forms, Windows, Classes, SysUtils, ShellAPI, ShlObj, ActiveX,
+  ZipMstr19, ZmUtils19;
 type
   TLineBreak = (lbWindows, lbLinux, lbMac);
 ,7 → 16,12
 function GetTempDirectory: String;
 function NormalizeLineBreaks(s: string; mode: TLineBreak): string;
 function ExtractFileNameWithoutExt(const fil: string): string;
-function SearchNextFreeName(s: string): string;
+function SearchNextFreeName(s: string; wantDir: boolean): string;
+function AdvSelectDirectory(const Caption: string; const Root: WideString;
+  var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;
+  AllowCreateDirs: Boolean = True): Boolean;
+function GetSpecialFolderPath(const Folder: integer): string;
+function IsExtractable(AFilename: string): boolean;
 implementation
 ,7 → 156,7
   result := Copy(ExtractFileName(fil), 1, Length(ExtractFileName(fil))-Length(ExtractFileExt(fil)));
 end;
-function SearchNextFreeName(s: string): string;
+function SearchNextFreeName(s: string; wantDir: boolean): string;
 var
   i: integer;
 begin
 ,27 → 163,172
   if not FileExists(s) and not DirectoryExists(s) then
   begin
     result := s;
+    if wantDir then result := IncludeTrailingPathDelimiter(result);
     Exit;
   end;
   i := 2;
-  if FileExists(s) then
+  if wantDir then
   begin
+    s := ExcludeTrailingPathDelimiter(s);
     repeat
-      result := Format('%s (%d)%s', [ExtractFileNameWithoutExt(s), i, ExtractFileExt(s)]);
+      result := Format('%s (%d)', [s, i]);
       inc(i);
-    until not DirectoryExists(result);
+    until not DirectoryExists(result) and not FileExists(result);
+    result := IncludeTrailingPathDelimiter(result);
   end
-  else if DirectoryExists(s) then
+  else
   begin
-    s := ExcludeTrailingPathDelimiter(s);
     repeat
-      result := Format('%s (%d)', [s, i]);
+      result := Format('%s (%d)%s', [ExtractFilePath(s)+ExtractFileNameWithoutExt(s), i, ExtractFileExt(s)]);
       inc(i);
-    until not DirectoryExists(result);                  // Todo: Legt man sich hier nun auf einen ordnernamen fest???
-    result := IncludeTrailingPathDelimiter(result);
+    until not DirectoryExists(result) and not FileExists(result);
   end;
 end;
+{
+  This code shows the SelectDirectory dialog with additional expansions:
+  - an edit box, where the user can type the path name,
+  - also files can appear in the list,
+  - a button to create new directories.
+  Dieser Code zeigt den SelectDirectory-Dialog mit zusätzlichen Erweiterungen:
+  - eine Edit-Box, wo der Benutzer den Verzeichnisnamen eingeben kann,
+  - auch Dateien können in der Liste angezeigt werden,
+  - eine Schaltfläche zum Erstellen neuer Verzeichnisse.
+  Ref: http://www.swissdelphicenter.ch/de/showcode.php?id=1802
+}
+function AdvSelectDirectory(const Caption: string; const Root: WideString;
+  var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;
+  AllowCreateDirs: Boolean = True): Boolean;
+  // callback function that is called when the dialog has been initialized
+  //or a new directory has been selected
+  // Callback-Funktion, die aufgerufen wird, wenn der Dialog initialisiert oder
+  //ein neues Verzeichnis selektiert wurde
+  function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam): Integer;
+    stdcall;
+//  var
+//    PathName: array[0..MAX_PATH] of Char;
+  begin
+    case uMsg of
+      BFFM_INITIALIZED: SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));
+      // include the following comment into your code if you want to react on the
+      //event that is called when a new directory has been selected
+      // binde den folgenden Kommentar in deinen Code ein, wenn du auf das Ereignis
+      //reagieren willst, das aufgerufen wird, wenn ein neues Verzeichnis selektiert wurde
+      {BFFM_SELCHANGED:
+      begin
+        SHGetPathFromIDList(PItemIDList(lParam), @PathName);
+        // the directory "PathName" has been selected
+        // das Verzeichnis "PathName" wurde selektiert
+      end;}
+    end;
+    Result := 0;
+  end;
+var
+  WindowList: Pointer;
+  BrowseInfo: TBrowseInfo;
+  Buffer: PChar;
+  RootItemIDList, ItemIDList: PItemIDList;
+  ShellMalloc: IMalloc;
+  IDesktopFolder: IShellFolder;
+  Eaten, Flags: LongWord;
+const
+  // necessary for some of the additional expansions
+  // notwendig für einige der zusätzlichen Erweiterungen
+  BIF_USENEWUI = $0040;
+  BIF_NOCREATEDIRS = $0200;
+begin
+  Result := False;
+  if not DirectoryExists(Directory) then
+    Directory := '';
+  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
+  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
+  begin
+    Buffer := ShellMalloc.Alloc(MAX_PATH);
+    try
+      RootItemIDList := nil;
+      if Root <> '' then
+      begin
+        SHGetDesktopFolder(IDesktopFolder);
+        IDesktopFolder.ParseDisplayName(Application.Handle, nil,
+          POleStr(Root), Eaten, RootItemIDList, Flags);
+      end;
+      OleInitialize(nil);
+      with BrowseInfo do
+      begin
+        hwndOwner := Application.Handle;
+        pidlRoot := RootItemIDList;
+        pszDisplayName := Buffer;
+        lpszTitle := PChar(Caption);
+        // defines how the dialog will appear:
+        // legt fest, wie der Dialog erscheint:
+        ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI or
+          BIF_EDITBOX * Ord(EditBox) or BIF_BROWSEINCLUDEFILES * Ord(ShowFiles) or
+          BIF_NOCREATEDIRS * Ord(not AllowCreateDirs);
+        lpfn    := @SelectDirCB;
+        if Directory <> '' then
+          lParam := Integer(PChar(Directory));
+      end;
+      WindowList := DisableTaskWindows(0);
+      try
+        ItemIDList := ShBrowseForFolder(BrowseInfo);
+      finally
+        EnableTaskWindows(WindowList);
+      end;
+      Result := ItemIDList <> nil;
+      if Result then
+      begin
+        ShGetPathFromIDList(ItemIDList, Buffer);
+        ShellMalloc.Free(ItemIDList);
+        Directory := Buffer;
+      end;
+    finally
+      ShellMalloc.Free(Buffer);
+    end;
+  end;
+end;
+function GetSpecialFolderPath(const Folder: integer): string;
+var
+  PIDL: PItemIDList;
+  Path: array[0..MAX_PATH] of char;
+  Malloc: IMalloc;
+begin
+  Path := '';
+  if Succeeded((SHGetSpecialFolderLocation(0, Folder, PIDL))) then
+    if (SHGetPathFromIDList(PIDL, Path)) then
+      if Succeeded(ShGetMalloc(Malloc)) then
+      begin
+        Malloc.Free(PIDL);
+        Malloc := nil;
+      end;
+  Result := Path;
+end;
+function IsExtractable(AFilename: string): boolean;
+var
+  q: integer;
+  uz: TZipMaster19;
+begin
+  // TODO: Ist die Funktion gut? Fraglich, ob EOC64 ein Teil von EOC ist.
+  uz := TZipMaster19.Create(nil);
+  try
+    q := uz.QueryZip(AFilename);
+    result := true;
+    if (q and zqbHasLocal) <> zqbHasLocal then result := false;
+    if (q and zqbHasCentral) <> zqbHasCentral then result := false;
+    if ((q and zqbHasEOC) <> zqbHasEOC) and
+       ((q and zqbHasEOC64) <> zqbHasEOC) then result := false;
+  finally
+    uz.Free;
+  end;
+end;
 end.

 /ExtractorPassword.dfm
 ,7 → 7,11
   ClientHeight = 140
   ClientWidth = 290
   Color = clBtnFace
-  ParentFont = True
+  Font.Charset = ANSI_CHARSET
+  Font.Color = clWindowText
+  Font.Height = -11
+  Font.Name = 'MS Sans Serif'
+  Font.Style = []
   OldCreateOrder = True
   Position = poMainFormCenter
   OnShow = FormShow
 ,7 → 20,7
   object PwEnterLabel: TLabel
     Left = 8
     Top = 56
-    Width = 120
+    Width = 117
     Height = 13
     Caption = 'Bitte Passwort eingeben.'
   end
 ,7 → 27,7
   object FileLabel: TLabel
     Left = 8
     Top = 6
-    Width = 29
+    Width = 28
     Height = 13
     Caption = 'Datei:'
   end

 /ExtractorComment.dfm
 ,10 → 5,10
   ClientHeight = 499
   ClientWidth = 521
   Color = clBtnFace
-  Font.Charset = DEFAULT_CHARSET
+  Font.Charset = ANSI_CHARSET
   Font.Color = clWindowText
   Font.Height = -11
-  Font.Name = 'Tahoma'
+  Font.Name = 'MS Sans Serif'
   Font.Style = []
   OldCreateOrder = False
   Position = poMainFormCenter
 ,7 → 38,13
     Height = 25
     Caption = 'OK'
     Default = True
+    Font.Charset = ANSI_CHARSET
+    Font.Color = clWindowText
+    Font.Height = -11
+    Font.Name = 'MS Sans Serif'
+    Font.Style = []
     ModalResult = 1
+    ParentFont = False
     TabOrder = 0
   end
   object CancelBtn: TButton
 ,7 → 54,13
     Height = 25
     Cancel = True
     Caption = 'Abbrechen'
+    Font.Charset = ANSI_CHARSET
+    Font.Color = clWindowText
+    Font.Height = -11
+    Font.Name = 'MS Sans Serif'
+    Font.Style = []
     ModalResult = 2
+    ParentFont = False
     TabOrder = 1
   end
 end

 /Extractor.bdsproj
 ,7 → 130,7
                         <Directories Name="UsePackages">False</Directories>
                 </Directories>
                 <Parameters>
-                        <Parameters Name="RunParams">helloworld.exe</Parameters>
+                        <Parameters Name="RunParams">single_file.zip</Parameters>
                         <Parameters Name="HostApplication"></Parameters>
                         <Parameters Name="Launcher"></Parameters>
                         <Parameters Name="UseLauncher">False</Parameters>
 ,7 → 173,6
                         <VersionInfoKeys Name="Webseite">www.viathinksoft.de</VersionInfoKeys>
                         <VersionInfoKeys Name="Projektleiter">Daniel Marschall - www.daniel-marschall.de</VersionInfoKeys>
                 </VersionInfoKeys>
     <Excluded_Packages>
       <Excluded_Packages Name="c:\programme\borland\bds\4.0\Bin\dclib100.bpl">Borland InterBase Express Components</Excluded_Packages>
       <Excluded_Packages Name="c:\programme\borland\bds\4.0\Bin\dclIntraweb_80_100.bpl">Intraweb 8.0 Design Package for Borland Development Studio 2006</Excluded_Packages>

Subversion Repositories autosfx

Compare Revisions

Regard whitespace Rev 1 → Rev 2