Zip erstellen über Shell API

[ConstantGardener]

Hallo zusammen,

ich habe im Blog von TMS Software folgende Unit gefunden. Mit Ihr lassen sich die windowseigenen Zip_Funktionen zum komprimieren und dekomprimieren nutzen.
Sehr komfortabel wenn es funktionieren würde. Die Funktionen kompilieren unter D2010 und D2006 ohne Probleme. Er schmeißt mir aber eine Access Violation beim CopyHere in
der Funktion ShellZip.

Kann das mal einer von Euch testen ? Irgendwelche erleuchtenden Infos ?

Code:

unit ShellZip;

interface

 function NumProcessThreads: integer;
 function ShellZip(zipfile, sourcefolder:string; filter: string = ''): boolean;
 function ShellUnzip(zipfile, targetfolder: string; filter: string = ''): boolean;


implementation

uses Comobj, Windows,Tlhelp32;

const
  SHCONTCH_NOPROGRESSBOX = 4;
  SHCONTCH_AUTORENAME = 8;
  SHCONTCH_RESPONDYESTOALL = 16;
  SHCONTF_INCLUDEHIDDEN = 128;
  SHCONTF_FOLDERS = 32;
  SHCONTF_NONFOLDERS = 64;

function ShellUnzip(zipfile, targetfolder: string; filter: string = ''): boolean;
var
  shellobj: variant;
  srcfldr, destfldr: variant;
  shellfldritems: variant;
begin
  shellobj := CreateOleObject('Shell.Application');

  srcfldr := shellobj.NameSpace(zipfile);
  destfldr := shellobj.NameSpace(targetfolder);

  shellfldritems := srcfldr.Items;
  if (filter <> '') then
    shellfldritems.Filter(SHCONTF_INCLUDEHIDDEN or SHCONTF_NONFOLDERS or SHCONTF_FOLDERS,filter);

  destfldr.CopyHere(shellfldritems, SHCONTCH_NOPROGRESSBOX or SHCONTCH_RESPONDYESTOALL);
end;

function NumProcessThreads: integer;
var
  hsnapshot: THandle;
  Te32: TTHREADENTRY32;
  proch: dword;
  procthreads: integer;
begin
  procthreads := 0;

  proch := GetCurrentProcessID;

  hSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);

  Te32.dwSize := sizeof(TTHREADENTRY32);

  if Thread32First(hSnapShot, Te32) then
  begin
    if te32.th32OwnerProcessID = proch then
      inc(procthreads);

    while Thread32Next(hSnapShot, Te32) do
    begin
      if te32.th32OwnerProcessID = proch then
        inc(procthreads);
    end;
  end;
  CloseHandle (hSnapShot);
  Result := procthreads;
end;

function ShellZip(zipfile, sourcefolder:string; filter: string = ''): boolean;
const
  emptyzip: array[0..23] of byte  = (80,75,5,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
var
  ms: TMemoryStream;
  shellobj: variant;
  srcfldr, destfldr: variant;
  shellfldritems: variant;
  numt: integer;
begin
  if not FileExists(zipfile) then
  begin
    // create a new empty ZIP file
    ms := TMemoryStream.Create;
    ms.WriteBuffer(emptyzip, sizeof(emptyzip));
    ms.SaveToFile(zipfile);
    ms.Free;
  end;

  numt := NumProcessThreads;

  shellobj := CreateOleObject('Shell.Application');

  srcfldr := shellobj.NameSpace(sourcefolder);
  destfldr := shellobj.NameSpace(zipfile);

  shellfldritems := srcfldr.Items;

  if (filter <> '') then
    shellfldritems.Filter(SHCONTF_INCLUDEHIDDEN or SHCONTF_NONFOLDERS or SHCONTF_FOLDERS,filter);

  destfldr.CopyHere(shellfldritems, 0);

  // wait till all shell threads are terminated
  while NumProcessThreads <> numt do
  begin
    sleep(100);
  end;
end;

end.

[SirThornberry]

Könntest du die genaue Fehlermeldung posten? Also die Accessviolation mit all den angezeigten Adressen und dazugehörigen Operationen.

[ConstantGardener]

...aber klar


---------------------------
Tmsshellzipdemo
---------------------------
Zugriffsverletzung bei Adresse 004A4C09 in Modul 'TMSShellZipDemo.exe'. Lesen von Adresse 00000000.
---------------------------
OK
---------------------------

in einem Demoprojekt mit FORM und nur einem Button drauf.

[SirThornberry]

Zitat:

Lesen von Adresse 00000000

Das sagt das irgendwo versucht wird von Adresse 0 zu lesen. Und 0 = nil
Es ist also irgendwo etwas nicht initialisiert. Ich vermute das shellfldritems oder dergleichen nil ist.
Am besten du setzt einfach mal einen Haltepunkt und gehst Schritt für Schritt das ganze durch und schaust welchen Wert die Variablen haben. Und noch besser wäre eine Fehlerprüfung rein zu bauen.
Also einfach prüfen ob irgendein Funktionsaufruf fehl schlägt (erkennt man meisten am Rückgabewert) und dann auch nur weitermachen wenn alles ok ist.
Denn derzeit arbeitet die Funktion alles nacheinander ab selbst wenn irgendwo eine Funktion nicht das notwendige für den weiteren Ablauf zurück gibt.

[ConstantGardener]

Hallo SirThornberry,

das ist schon klar. Die Funktion ist nur so aus dem Blog kopiert. Ich habe noch keinerlei Veränderungen eingebaut. Da fehlen z.B. auch noch die Rückgabewerte usw. Ich wollte es erstmal im Orginal von TMS (Bruno der Chef) versuchen. Er scheint aber das Shellobject, bzw. Teile davon nicht oder falsch zu initialisieren. Scheinbar kennt er das Objekt und die Propertys aber, da es ja kompiliert.

Hast Du es mal bei Dir versucht ?

[paperboy]

hey ConstantGardener,

Erstmal vorweg:
Mich wundert das es sich für dich überhaupt so kompilieren lässt.. da wird doch ein MemoryStream und die Funktion FileExists verwendet?!
Also ich musste noch die Classes und SysUtils Units einbinden damit das Ding überhaupt anstandslos kompiliert wird :gruebel:

Danach hab ich aber keine Probleme beim erstellen von zip Dateien... Naja bis auf die Tatsache das sich mein Testapp aufgrund der Schleife

Delphi-Quellcode:

while NumProcessThreads <> numt do
begin
  sleep(100);
end;

bei einigen Archiven aufhängt...

Beim entpacken in einen Ordner gibt es bei mir nur Probleme wenn der Ordner nicht vorhanden ist...

Wo genau kracht es denn bei dir?

[ConstantGardener]

Ja, da hast Du recht. Die SysUtils fehlen hier im Quelltext. Hatte Sie aber natürlich drin. Frage mich gerade wo die geblieben Sind beim Kopieren. :gruebel:

How ever, kompiliert bekomme ich es.

Bei

Delphi-Quellcode:

  destfldr.CopyHere(shellfldritems, 0);

knallts. Das Zip Archiv bleibt lehr. Unzip hab ich noch garnicht probiert.

[paperboy]

mhhh...

Wie sieht denn dein Aufruf aus? Benutzt du irgendwelche Filter?
Wohin willst du die zip Datei schreiben? Schreibrechte vorhanden?

Den Fehler bekomm ich namlich auch wenn ich von einem nicht Admin Konto auf C:\ schreiben will...
Denn dann setzt

Delphi-Quellcode:

destfldr := shellobj.NameSpace(zipfile);

destfldr auf $00000000.

[sx2008]

Zitat:

Zitat von paperboy

Denn dann setzt

Delphi-Quellcode:

destfldr := shellobj.NameSpace(zipfile);

destfldr auf $00000000.

Genau das ist das Problem.
Die Funktion NameSpace() akzeptiert als Argument nur ein Variant.
WideStrings oder Strings führen zu dem Fehler, dass zwar ein Ergebnis vom Typ varDispatch zurückgeliefert wird, aber der Zeiger = nil ist.
Leichte Schlamperei von Microsoft!

Hier die überarbeitete Unit.
Wichtig ist übrigens, dass die Zipdatei mit absolutem Pfad angegeben wird.

Delphi-Quellcode:

unit ShellZipTool;

interface


type
  TShellZip = class(TObject)
  private
    FFilter: string;
    FZipfile: WideString;
    shellobj: Olevariant;

    procedure CreateEmptyZip;
    function GetNameSpaceObj(x:OleVariant):OleVariant;
    function GetNameSpaceObj_zipfile:OleVariant;

  public
     procedure ZipFolder(const sourcefolder:WideString);
     procedure Unzip(const targetfolder: WideString);

     property Zipfile:WideString read FZipfile write FZipfile;
     property Filter:string read FFilter write FFilter;
  end;

function NumProcessThreads: integer;



implementation

uses Classes, Comobj, Windows, Tlhelp32, SysUtils, Variants;

const
  SHCONTCH_NOPROGRESSBOX = 4;
  SHCONTCH_AUTORENAME = 8;
  SHCONTCH_RESPONDYESTOALL = 16;
  SHCONTF_INCLUDEHIDDEN = 128;
  SHCONTF_FOLDERS = 32;
  SHCONTF_NONFOLDERS = 64;


function IsValidDispatch(const v:OleVariant):Boolean;
begin
  result := (VarType(v)=varDispatch) and Assigned(TVarData(v).VDispatch);
end;


function NumProcessThreads: integer;
var
  hsnapshot: THandle;
  Te32: TTHREADENTRY32;
  proch: dword;
begin
  Result := 0;

  proch := GetCurrentProcessID;

  hSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);

  Te32.dwSize := sizeof(TTHREADENTRY32);

  if Thread32First(hSnapShot, Te32) then
  begin
    if te32.th32OwnerProcessID = proch then
      inc(Result);

    while Thread32Next(hSnapShot, Te32) do
    begin
      if te32.th32OwnerProcessID = proch then
        inc(Result);
    end;
  end;
  CloseHandle(hSnapShot);
end;



{ TShellZip }

procedure TShellZip.CreateEmptyZip;
const
  emptyzip: array[0..23] of byte  = (80,75,5,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
var
  ms: TMemoryStream;
begin
  // create a new empty ZIP file
  ms := TMemoryStream.Create;
  try
    ms.WriteBuffer(emptyzip, sizeof(emptyzip));
    ms.SaveToFile(Zipfile);
  finally
    ms.Free;
  end;
end;

function TShellZip.GetNameSpaceObj(x:OleVariant): OleVariant;
begin
  // WARNING:
  // the argument of .NameSpace must be a OleVariant
  // don't change "x" to string or WideString
  Result := shellobj.NameSpace(x);
end;

function TShellZip.GetNameSpaceObj_zipfile: OleVariant;
begin
  Result := GetNameSpaceObj(Zipfile);
  if not IsValidDispatch(Result) then
     raise EInvalidOperation.CreateFmt('<%s> invalid zipfile', [zipfile]);
end;


procedure TShellZip.ZipFolder(const sourcefolder: WideString);
var
  srcfldr, destfldr: OleVariant;
  shellfldritems: Olevariant;
  numt: integer;
begin
  if not FileExists(zipfile) then
  begin
    CreateEmptyZip;
  end;

  numt := NumProcessThreads;

  shellobj := CreateOleObject('Shell.Application');

  srcfldr := GetNameSpaceObj(sourcefolder);
  if not IsValidDispatch(srcfldr) then
     raise EInvalidOperation.CreateFmt('<%s> invalid source', [sourcefolder]);

  destfldr := GetNameSpaceObj_zipfile;

  shellfldritems := srcfldr.Items;

  if (filter <> '') then
    shellfldritems.Filter(SHCONTF_INCLUDEHIDDEN or SHCONTF_NONFOLDERS or SHCONTF_FOLDERS,filter);

  destfldr.CopyHere(shellfldritems, 0);

  // wait till all shell threads are terminated
  while NumProcessThreads <> numt do
  begin
    sleep(100);
  end;
end;


procedure TShellZip.Unzip(const targetfolder: WideString);
var
  srcfldr, destfldr: Olevariant;
  shellfldritems: Olevariant;
begin
  shellobj := CreateOleObject('Shell.Application');

  srcfldr := GetNameSpaceObj_zipfile;

  destfldr := GetNameSpaceObj(targetfolder);
  if not IsValidDispatch(destfldr) then
     raise EInvalidOperation.CreateFmt('<%s> invalid target folder', [targetfolder]);

  shellfldritems := srcfldr.Items;
  if (filter <> '') then
    shellfldritems.Filter(SHCONTF_INCLUDEHIDDEN or SHCONTF_NONFOLDERS or SHCONTF_FOLDERS,filter);

  destfldr.CopyHere(shellfldritems, SHCONTCH_NOPROGRESSBOX or SHCONTCH_RESPONDYESTOALL);
end;

end.

[Garfield]

Interessantes Thema. Kann man da auch einzelne Dateien oder Dateilisten verwenden oder geht das nur mit Verzeichnissen?

Ist es Absicht, dass die Variablen FFilter und FZipfile nur bei der Deklaration der Properties verwendet werden?

[ConstantGardener]

Hallo sx2008,

danke für die angepasste Unit. :gruebel: Das tut erstmal. Wobei er nach dem erstellen des Zips abschmiert bzw. in der Schleife hängen bleibt die auf das beenden der ShellThreads wartet.

Ausserdem schmeisst mir D2010 eine Access Violation wenn ich die TestApp mit Debugger starte. Das könnte aber auch an meiner Installation liegen. Irgendwas läuft da noch nicht ganz rund. :wall:

Aber Danke schonmal...

cg

[Luckie]

Wozu ist denn das

Delphi-Quellcode:

// wait till all shell threads are terminated

erforderlich?

[ConstantGardener]

@Luckie

... laut Blogeintrag um mit der Ausführung zu warten bis das Zip auch wirklich fertig erstellt ist. Wartet man nicht wird das Zip-Archiv im Hintergrund erstellt und die Funktion kehrt sofort zurück.
Das kann in einigen Bereichen (wie bei mir) problematisch sein.

[Daniel]

Kurz am Rande: Wäre einer von Euch so nett, die hier erarbeiteten Lösungen auch an den Blog-Autor von TMS zurück zu senden?

[ConstantGardener]

@Daniel

sobald das gut funzt geht das sofort zurück an Bruno. BTW dort hatte scheinbar noch keiner Probleme. (siehe Comments)

ps. : Dein Avatar ist ja.... süß Angst einflößend... irgendwie

[Schwedenbitter]

Hallo,

könnte mir bitte jemand mal einen funktionierenden Beispielcode senden oder hier im Forum einstellen?

Ich habe TurboDelphi und habe mit beiden Units versucht, eine zip-Datei zu entpacken. Das Entpacken ist auch mein Fernziel. Ich bekomme aber stets Fehlermeldungen:
Bei der ersten Unit kommt trotz Anpassung von String nach WideString stets eine Zugriffsverletzung wegen eines Leseversuches von Adresse 0. Bei der zweiten Unit (objektorientiert) bekomme ich immer eine Exception der Klasse EOleException mit der Meldung 'Das System kann die angegebene Datei nicht finden'. Die zip-Datei existiert und Sie wurde mit dem kompletten Pfad 'C:\...meine.zip' angegeben.

Ich habe keine Ahnung, was ich verkehrt mache, denn laut ConstantGardener funktioniert das wohl. Die Zip-Datei ist auch OK. Jedenfalls kann sie XP mit Bordmitteln entpacken. Und nichts anderes tut der Code, wenn ich das richtig verstehe.

Danke im Voraus, Alex

[himitsu]

Und an welchen Stellen tauchen denn diese "Adresse 0"-Exceptions denn auf? (laut deinem Debugger)

[Schwedenbitter]

So sieht die Funktion / der Aufruf aus:

Delphi-Quellcode:

Function ShellUnzip(Zipfile, Targetfolder: WideString;
  Filter: String = ''): Boolean;
Var
  Shellobj       : Variant;
  SrcFldr        : Variant;
  DestFldr       : Variant;
  ShellFldrItems : variant;
Begin
  Shellobj:=CreateOleObject('Shell.Application');
  SrcFldr:= Shellobj.NameSpace(Zipfile);
  DestFldr:=Shellobj.NameSpace(TargetFolder);

  ShellFldrItems:=SrcFldr.Items;  // <- hier kommt die Zugriffsverletzung
                                 // Ich VERMUTE, dass es daran liegt, dass ich zwar die zip-Datei
                                 // definiert habe, diese aber irgendwie noch GEÖFFNET werden muss.
  If (Filter <> '') Then
    ShellFldrItems.Filter(128 or 64 or 32, Filter);
  DestFldr.CopyHere(ShellFldrItems, 4 or 16);
End;

Procedure TForm1.Button1Click(Sender: TObject);
Var
  tmpF      : WideString;
  Target    : WideString;
Begin
  If Not OOpen.Execute Then Exit;

  Target:=ExtractFilePath(OOpen.FileName);
  tmpF:=Target + 'tmp.zip';
  RenameFile(OOpen.FileName, tmpF);
  Try
    ShellUnzip(tmpF, Target, 'content.xml');
  Except  End;
  RenameFile(tmpF, OOpen.FileName);
End;

Das ist der Code für die objektorientierte Unit:

Delphi-Quellcode:

procedure TShellZip.Unzip(const targetfolder: WideString);
var
  srcfldr, destfldr: Olevariant;
  shellfldritems: Olevariant;
begin
  shellobj:=CreateOleObject('Shell.Application');
  srcfldr:= GetNameSpaceObj(Fzipfile);  // <- hier kommt der Fehler
                                       // 'Das System kann die angegebene Datei nicht finden'


  srcfldr:= GetNameSpaceObj_zipfile;       // <- Variante laut sx2008 -> Bringt dieselbe Fehlermeldung.

  destfldr:=GetNameSpaceObj(targetfolder);
  ...


Procedure TForm1.Button1Click(Sender: TObject);
Var
  tmpF          : WideString;
  Target        : WideString;
Begin
  If Not OOpen.Execute Then Exit;

  Target:=ExtractFilePath(OOpen.FileName);
  tmpF:=Target + 'tmp.zip';
  RenameFile(OOpen.FileName, tmpF);
  With TShellZip.Create Do
  Try
    ZipFile:=tmpF;
    Filter:='content.xml';
    Unzip(Target);
  Finally
    Free;
  End;
  RenameFile(tmpF, OOpen.FileName);
End;

Hier kommt dann die Meldung mit der nicht angegebenen Datei.

Ich suche meine Fehler auch gern selber. Daher die Bitte nach einem funktionierenden Beispiel, damit ich sehen kann, was anders gemacht wurde.

Gruß und Dank, Alex

[himitsu]

Versuch mal dieses:

Delphi-Quellcode:

Function ShellUnzip(Zipfile, Targetfolder: WideString;
...
begin
  Shellobj:=CreateOleObject('Shell.Application');
  if not Assigned(Shellobj) then RaiseLastOSError;
  SrcFldr:= Shellobj.NameSpace(Zipfile);
  if not Assigned(SrcFldr) then RaiseLastOSError;
  DestFldr:=Shellobj.NameSpace(TargetFolder);
  if not Assigned(DestFldr) then RaiseLastOSError;
  ...

Zitat:

ShellFldrItems:=SrcFldr.Items;

Wenn SrcFldr hier NIL ist, dann bedeutet das Shellobj.NameSpace(Zipfile) hat nix zurückgeliefert und da in diesen Codes nirgendwo eventuelle Fehler abgefangen werden, muß es ja irgendwo auch mal heftig knallen.

[Schwedenbitter]

Delphi-Quellcode:

If not Assigned(Shellobj) then RaiseLastOSError;

will mein Compiler nicht. Er meckert dann über "E2008 inkompatible Typen".

Und dann muss ich sagen: Es funktioniert. Vermutlich tat es das schon die ganze Zeit.
Mein Problem ist folgendes: Ich möchte eine odt-Datei entapcken. Das sind Dateien von OpenOffice, deren Text üblicher Weise in der content.xml gespeichert wird. Das ganze wird dann in einen Container mit anderen Daten gepackt. Ich ging immer davon aus, dass das Standard-zip ist. Denn wenn ich die Datei in irgendwas.zip umbenenne, kann ich sie mit Windows Bordmitteln entpacken (Inhalt ansehen mit Doppelklick und entpacken nach Rechtsklick). Andere Programme (z.B. mein uralter Norton Commander) bringen mir bei odt-Dateien Fehlermeldungen. Scheinbar schlägt das dann auch auch bei der Verwendung der API durch.
Andere Dateien ließen sich jedenfalls (jetzt) problemlos entpacken.

Entschuldigt daher meine Aufregung.

Ich frage mich jetzt bloß noch, warum das im BS geht und beim Aufruf aus Delphi nicht (mehr)? Gelöst habe ich das jetzt mit der Unit SciZipFile. Die benutzt keine DLL (was mir besonders wichtig war), ist sehr klein (= nimmt in meiner fertigen exe nur ca. 1KB mehr ein) und ist sehr schnell.

Danke nochmal für die Hilfe
<OT>Warum bekomme ich keine mail mehr, wenn ich eine Antwort auf eine Frage bekommen habe? Diese Option war nach dem Update der Forensoftware zwar ausgeschaltet. Aber auch nach dem Einschalten tut sich nichts.</OT>

Gruß, Alex

[Bbommel]

Hach, tolles Thema hier, man kann es alle paar Tage/Wochen mal wieder aufwärmen. ;)

Ich wollte die hier vorgestellte Lösung, um die Windows-Shell zum Erstellen von ZIPs zu benutzen, auch in ein Programm von mir einbauen. Kleine Besonderheit: Ich will nicht ein ganzes Verzeichnis packen, sondern nur ein paar bestimmte Dateien in diesem Verzeichnis. Setze ich hier in der Unit allerdings den Filter, dann zeigt Windows den Fortschritts-Dialog (zumindest bei mir) nicht mehr an, was ja irgendwie auch blöd ist. Also dachte ich mir: Macht ja nix, bastelst du dir halt selber etwas drumrum, das anzeigt welche Dateien gerade behandelt werden.

Die zentrale Prozedur sieht dann (erstmal) so aus:

Delphi-Quellcode:

procedure ZipFileList (aSrcDir: string; aFilter: string; aDstFile: string);

var myZip: TShellZip;
    formZip: TformZip;
    foundFiles: TStringList;
    findRec: TSearchRec;
    findResult: integer;
    newItem: TListItem;
  I: Integer;

begin
  foundFiles:=TStringList.Create;

  findResult:=FindFirst(aSrcDir+'\'+aFilter,0,findRec);
  while findResult=0 do begin
    foundFiles.Add(ExtractFileName(findRec.Name));
    findResult:=FindNext(findRec);
  end;

  formZip:=TformZip.Create(nil);
  for I := 0 to foundFiles.Count - 1 do begin
    newItem:=formZip.ListFileStatus.Items.Add;
    newItem.Caption:=foundFiles[i];
  end;
  formZip.Show;
  Application.ProcessMessages;

  myZip:=TShellZip.Create;
  myZip.Zipfile:=aDstFile;
  i:=0;
  while (i<=foundFiles.Count-1) and (not formZip.isCancelled) do begin
    formZip.ListFileStatus.Items[i].SubItems.Add('Läuft...');
    myZip.Filter:=foundFiles[i];
    myZip.ZipFolder(aSrcDir);
    formZip.ListFileStatus.Items[i].SubItems[0]:='OK';
    inc(i);
    Application.ProcessMessages;
  end;

  formZip.Free;
  myZip.Free;
  foundFiles.Free;
end;

(das Form hat ein ListView, um die Dateien anzuzeigen, die abgearbeitet werden, und einen Abbrechen-Button)

Läuft eigentlich auch alles total super, außer: Beim allerersten Aufruf von myZip.ZipFoler braucht diese Funktion unglaublich lange, um wieder zurückzukommen, obwohl die Datei schon längst zur Zip-Datei hinzugefügt wurde. Die Funktion hängt recht lange hier rum:

Delphi-Quellcode:

  // wait till all shell threads are terminated
  while NumProcessThreads <> numt do
  begin
    sleep(100);
  end;

Irgendwie braucht es total lange, bis gemerkt wird, dass der Thread beendet wurde. Aber: Nur beim allerersten Aufruf, bei den weiteren Aufrufen kommt die Funktion sofort nach getaner Arbeit zurück.

Hat irgendwer eine Idee, ob man noch etwas dagegen tun könnte?

Danke und bis denn
Bommel

[MarioL]

Hallo Bommel, vielleicht nicht die eleganteste Lösung, aber damit funktioniert es auch beim ersten Aufruf zügig :idea::

Delphi-Quellcode:

procedure TShellZip.ZipFolder(const sourcefolder: WideString);
var
  srcfldr, destfldr: OleVariant;
  shellfldritems: Olevariant;
  numt: integer;
begin
  if not FileExists(zipfile) then
  begin
    CreateEmptyZip;
  end;

  numt := NumProcessThreads;

  if numt = 1 then numt := 2;
// (beim ersten Aufruf numt auf 2 setzen)

...

MfG MarioL

[Bbommel]

Hallo Mario,

bei mir hat das so leider nicht funktioniert. Im Gegenteil: numt wurde auf 2 gesetzt, aber NumProcessThreads ist bei mir eigentlich nie 2 geworden, so dass die Funktion am Ende in einer Endlosschleife festhing.

Aber dein Beitrag hat mich immerhin dazu motiviert, mir das Thema noch ein weiteres Mal näher anzuschauen. Dabei habe ich gesehen, dass auch schon die Befehle GetNameSpaceObj und GetNameSpaceObj_zipfile neue Threads erzeugen, die sich so schnell auch nicht beenden und wahrscheinlich Schuld daran sind, dass die Funktion beim ersten Durchlauf so lange braucht, um zu merken, dass sie fertig ist.

Was ich nun also gemacht habe, ist, die Abfrage

Delphi-Quellcode:

numt := NumProcessThreads;

soweit nach hinten zu setzen, dass sie erst unmittelbar vor dem CopyHere kommt.

Jetzt läuft es genauso, wie ich mir das erhofft habe, aber ob das nun auch immer unfallfrei passiert, da bin ich mir noch nicht ganz sicher. Ich könnte mir - allerdings ohne viel Ahnung davon zu haben, was da gerade so genau eigentlich passiert - vorstellen, dass sich die Threads, die von z.B. von GetNameSpaceObj erzeugt wurden, beenden, während das zippen noch läuft, wenn bspw. besonders große Dateien gezippt werden. Dann könnte es passieren, dass die Funktion schon zu früh oder auch gar nicht zurückkehrt.

Naja, für meine Zwecke wird es wahrscheinlich reichen...

Hier noch mal die Funktion in der kompletten Fassung:

Delphi-Quellcode:

procedure TShellZip.ZipFolder(const sourcefolder: WideString);
var
  srcfldr, destfldr: OleVariant;
  shellfldritems: Olevariant;
  numt: integer;
begin
  if not FileExists(zipfile) then
  begin
    CreateEmptyZip;
  end;

  shellobj := CreateOleObject('Shell.Application');

  srcfldr := GetNameSpaceObj(sourcefolder);
  if not IsValidDispatch(srcfldr) then
     raise EInvalidOperation.CreateFmt('<%s> invalid source', [sourcefolder]);

  destfldr := GetNameSpaceObj_zipfile;

  shellfldritems := srcfldr.Items;

  if (filter <> '') then
    shellfldritems.Filter(SHCONTF_INCLUDEHIDDEN or SHCONTF_NONFOLDERS or SHCONTF_FOLDERS,filter);

  numt := NumProcessThreads;

  destfldr.CopyHere(shellfldritems, 0);
  sleep(100);


  // wait till all shell threads are terminated
  while NumProcessThreads <> numt do
  begin
    sleep(100);
  end;
end;

Bis denn
Bommel

[MarioL]

Hallo Bommel, das ist auf jeden Fall die elegantere Lösung.

(bei mir erhalte ich als erstes und letztes Result von NumProcessThreads immer 2, egal mit welchen Dateien ich teste)

MfG MarioL

[peschai]

Ergänzende Frage hierzu
Was muss ich im Übergabeparameter "Filter" eingeben um nur eine einzelne Datei (z.b xyz.csv) unzippen.
Mit '*' gehen alle ...
wenn ich 'xyz.csv' angebe wird nichts extrahiert, obwohl die Datei im Archiv vorhanden ist...

Ergänzender Hinweis:
...,WideString('*')); funktioniert
...,WideString('*.csv')); funktioniert nicht

evt. war es etwas zu ungenau:
Mit WinZip erstellte pkzip2.0 kompatible ZIPDatei mit einem verzeichnis und zwei Dateien.
Eine Datei 'xyz.csv' möchte ich unzippen, aber die Filterungs geht nicht ...
...FolderItems.Filter(SHCONTF_NONFOLDERS,WideStrin g('')); FolderItems.Count dann incl Folder
...FolderItems.Filter(SHCONTF_NONFOLDERS,WideStrin g('*')); FolderItems.Count dann ohne Folder
...FolderItems.Filter(SHCONTF_NONFOLDERS,WideStrin g('*.*')); FolderItems.Count ist dann 0 ???????
...FolderItems.Filter(SHCONTF_NONFOLDERS,WideStrin g('*.csv')); FolderItems.Count ist dann 0 ???????
...FolderItems.Filter(SHCONTF_NONFOLDERS,WideStrin g('xyz.csv')); FolderItems.Count ist dann 0 ???????

[peschai]

Kann mir hier jemand helfen ?
Habe es och etwas genauer beschrieben Danke

[peschai]

Kann es ein, daß die Filterfunktion auf einzelne Dateien im Fall von ZIP Dateien nicht richtig funktioniert ?

Wenn ich die Dateien auspacke, und das Verzeichnis angebe anstelle deer ZipDatei dann funktioniert der FILTER wie erwartet.

Kann mir hier jemand helfen ?

[froschprinz]

Hallo,
ich würde gerne dieses Thema gerne noch einmal aufwärmen.

Leider funktioniert es bei mir nicht immer, durch die Anzahl der Threads (NumProcessThreads) das Ende zu erkennen. Manachmal bleibt ein Thread übrig und die Schleife läuft endlos oder es dauert unendlich lange.

Gibt es den keine andere Möglichkeit zu erkennen, ob die Datei schon fertig gezipt wurde????

[Bbommel]

Hallo froschprinz,

hast du meine Variante benutzt (Post #23) oder eine der vorigen Versionen? So, wie ich es hier gemacht habe, läuft es bei mir und meinen Kunden in geschätzten 98 % der Fälle problemlos unter den unterschiedlichsten Windows-Versionen.

Besser habe ich es nicht hinbekommen - CopyHere läuft halt nun mal leider los und gibt keine Rückmeldung mehr. :-(

Wenn du also eine hundertprozentige Lösung brauchst, wirst du wohl um irgendwelche Komponenten nicht drumrum kommen...

Falls es doch noch eine bessere Lösung gibt, wäre ich auch dran interessiert - ich habe trotz langem Suchen und Testen nichts gefunden.

Bis denn
Bommel