Delphi-PRAXiS - Delphi Problem mit OnWork

Erster:

Delphi-Quellcode:

			unit WebUpdateThread;

interface

uses

  classes, IdComponent, IdHTTP;

type

  TOnWorkEvent = procedure(Sender: TThread; AWorkCount: Integer) of object;

  TDownloadThread = Class (TThread)

    private

      fIdHTTP: TIdHTTP;

      fName: string; // Name einer herunterzuladenden Datei

      fPfad: string; // wohin soll die Datei auf Platte gespeichert werden

      fURL: string; // URL der Datei

      fWorkCount: integer;

      fOnWorkEvent: TOnWorkEvent;

      procedure InternalOnWork (Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer);

      procedure DoNotifyWork;

    protected

      procedure execute; override;

    public

      property name: string read fName write fName;

      property Pfad: string read fPfad write fPfad;

      property URL: string read fURL write fURL;

      property OnWork: TOnWorkEvent read FOnWorkEvent write FOnWorkEvent;

  end;

implementation

uses

  SysUtils;

procedure TDownloadThread.Execute;

var

  fs: TFileStream;

begin

  fIdHTTP := TIdHTTP.Create(nil);

  fIdHTTP.OnWork := InternalOnWork;

  fs := TFileStream.Create (fPfad + fName, fmCreate or fmShareExclusive);

  try

    fIdHTTP.Get(fURL + fName, fs);

  finally

    fs.Free;

    fIdHTTP.Free;

  end;

end;

procedure TDownloadThread.InternalOnWork(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer);

begin

  FWorkCount := AWorkCount;

  Synchronize(DoNotifyWork);

end;

procedure TDownloadThread.DoNotifyWork;

begin

  if Assigned(OnWork) then

    OnWork (Self, FWorkCount);

end;

end.

Zweiter:

Delphi-Quellcode:

			{WebUpdate V1.00.3, 28.03.2008}

{Freeware-Komponente fuer ein automatisches Programmupdate.}

{Autor: Marco Steinebach - [email]marco.steinebach@t-online.de[/email]}

unit WebUpdate;

{ Compiler-Schalter:

 wird der nachfolgende Schalter "NurAlsObjekt" gesetzt,

 wird die Komponente ohne die möglichkeit der Einbindung

 in den Objektinspektor compiliert, sinnvoll beispielsweise

 bei Einsatz von Turbo-Explorer (keine Fremdkomponenten), oder KonsolenApps.

 (Danke an WebCSS!) }

 {.$DEFINE NurAlsObjekt}

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP,

  WebUpdateThread;

type

  TWUDatei = record // TWU steht für TWebUpdate

    name,

    Pfad: string;

  end;

  TWUDateien = array of TWUDatei; // Liste aller runterzuladenden Dateien

  TOnWorkEvent = procedure(Sender: TThread; AWorkCount: Integer) of object;

  TOnUpdateGefunden = Procedure (sender: TObject; var Runterladen: boolean) of object;

  TOnDownloadKomplett = Procedure (sender: TObject; var Start: boolean) of object;

{$IFDEF NurAlsObjekt}

  TWebUpdate = class(TObject)

{$ELSE}

  TWebUpdate = class(TComponent)

{$ENDIF}

  private

    { Private-Deklarationen }

    fIniName: String; // Name der Versionsdatei

    fUpdateURL: String; // HTTP-Verzeichnis zur Versionsdatei und den Programmen

    fNeueVersion: String; // im falle eines Updates, die neue Programmversion

    fWhatsNewListe: TStringList; // Im Falle eines Updates, die Neuerungen

    fDateien: TWUDateien; // Die Dateien, die heruntergeladen werden sollen

    fNaechsteDatei: integer; // welche Datei kommt als nächste?

    fDirektesUpdate: boolean;

    fIdHTTP: TIdHTTP;

    fDownloadThread: TDownloadThread;

    fOnUpdateGefunden: TOnUpdateGefunden;

    fOnDownloadKomplett: TOnDownloadKomplett;

    fOnDownloadFortschritt: TOnWorkEvent;

    procedure SetIniName(const value: String);

    procedure SetUpdateUrl (const value: string);

    procedure DownloadStart;

    // startet den DownloadThread für eine Datei.

    procedure DownloadEnde (sender: TObject);

    // wird nach beendigung des Download-Threads ausgeführt.

    // ist noch eine Datei herunterzuladen, wird wieder

    // DownloadStart ausgeführt.

    procedure ErstelleBatchDatei;

    // erstellt die Batch zum Starten des direkten Updates.

  protected

    { Protected-Deklarationen }

  public

    { Public-Deklarationen }

    {$IFDEF NurAlsObjekt}

      constructor Create; override;

    {$ELSE}

      constructor Create (aOwner: TComponent); override;

    {$ENDIF}

    destructor Destroy; override;

    property NeueVersion: string read fNeueVersion;

    property WhatsNewListe: TStringList read fWhatsNewListe;

    property Dateien: TWUDateien read fDateien;

    procedure CheckForUpdates;

  published

    { Published-Deklarationen }

    property IniName: String read fIniName write SetIniName;

    property UpdateURL: string read fUpdateURL write SetUpdateURL;

    property OnUpdateGefunden: TOnUpdateGefunden read fOnUpdateGefunden write fOnUpdateGefunden;

    property OnDownloadKomplett: TOnDownloadKomplett read fOnDownloadKomplett write fOnDownloadKomplett;

    property OnDownloadFortschritt: TOnWorkEvent

      read fOnDownloadFortschritt write fOnDownloadFortschritt;

  end;

procedure Register;

implementation

uses

  IniFiles, ShellApi, FileCtrl, MardyTools;

{$IFNDEF NurAlsObjekt}

procedure Register;

begin

  RegisterComponents('Standard', [TWebUpdate]);

end;

{$ENDIF}

{$IFDEF NurAlsObjekt}

constructor TWebUpdate.Create;

{$ELSE}

constructor TWebUpdate.Create (aOwner: TComponent);

{$ENDIF}

begin

  inherited Create {$IFNDEF NurAlsObjekt} (aOwner){$ENDIF } ;

  fWhatsNewListe := TStringList.Create;

  fIdHTTP := TIdHTTP.Create (self);

  fUpdateUrl := '';

  fIniName := '';

  fNeueVersion := '';

  fDateien := nil;

  fDirektesUpdate := false;

end;

Destructor TWebUpdate.Destroy;

begin

  fWhatsNewListe.Free;

  fIdHTTP.Destroy;

  fDateien := nil;

  inherited Destroy;

end;

procedure TWebUpdate.SetIniName(const value: string);

begin

  if fIniName <> Value then

    fIniName := Value;

end;

procedure TWebUpdate.SetUpdateURL(const value: string);

begin

  if fUpdateURL <> Value then

  begin

    fUpdateURL := Value;

    if copy (UpperCase (fUpdateUrl), 1, 7) <> 'HTTP://' then

      fUpdateURL := 'http://' + fUpdateURL;

    if copy(fUpdateURL, Length(fUpdateURL), 1) <> '/' then

      fUpdateURL := fUpdateURL + '/';

  end;

end;

procedure TWebUpdate.ErstelleBatchDatei;

var

  l: TStringList;

  Batchname, ProgLW, ProgPfad, ProgName: String;

begin

  l := TStringList.Create;

  Batchname := ExtractFilePath (Application.Exename) + 'Update.bat';

  ProgLW := ExtractFileDrive (Application.ExeName);

  ProgPfad := ExtractFilePath (Application.ExeName);

  ProgName := ExtractFileName (Application.ExeName);

  with l do

  begin

    add ('@Echo off');

    Add ('PING -n 3 127.0.0.1>nul'); // für die Wartezeit.

    Add (ProgLW);

    Add ('CD ' + ProgPfad);

    Add ('del ' + ProgName);

    Add ('ren ' + fDateien[0].name + ' ' + ProgName);

    Add (ProgName); // Programm wieder starten

    Add ('del ' + BatchName);

  end;

  l.SaveToFile (BatchName);

  l.Free;

  shellExecute (application.handle, 'open', PChar(BatchName), '', PChar(ExtractFilePath(BatchName)), SW_HIDE);

end;

procedure TWebUpdate.DownloadStart;

begin

  with fDateien[fNaechsteDatei] do

  // testen, ob der angegebene Pfad existiert, wenn nicht, anlegen!

    if not DirectoryExists (Pfad) then

      if not CreateDir (pfad) then

      begin

        Fehler ('Verzeichnis '+Pfad+' kann nicht erstellt werden!');

        fNaechsteDatei := fNaechsteDatei + 1;

        exit

      end;

  fDownloadThread := TDownloadThread.Create (true);

  with fDownloadThread do

  begin

    FreeOnTerminate := true;

    OnTerminate := DownloadEnde;

    Name := fDateien[fNaechsteDatei].name;

    Pfad := fDateien[fNaechsteDatei].pfad;

    URL := fUpdateURL;

    OnWork := fOnDownloadFortschritt;

    Resume;

  end;

  fNaechsteDatei := fNaechsteDatei + 1;

end;

procedure TWebUpdate.DownloadEnde(sender: TObject);

var

  start: boolean;

begin

  if fNaechsteDatei <= Length (fDateien) -1 then

  // es sind noch Dateien zum herunterladen da...

  begin

    DownloadStart;

    exit

  end;

  start := false;

  if assigned (OnDownloadKomplett) then

    OnDownloadKomplett (self, start);

  if not start then exit;

  if fDirektesUpdate then

    ErstelleBatchDatei

  else

    with fDateien[0] do

      shellexecute (application.handle, 'open', PChar(pfad + name), '', PChar(pfad), SW_SHOWNORMAL);

  Application.MainForm.Close;

end;

procedure TWebUpdate.CheckForUpdates;

var

  ini: TIniFile;

  fs: TFileStream;

  rv, lv, TempDir, ProgDir: string;

  i, ma, mi, re, bu: integer;

  Runterladen: boolean;

begin

  // Tempverzeichnis festlegen.

  TempDir := LeseUmgebungsVariable ('TEMP');

  SetLength (TempDir, length (TempDir)-1); // Null am Ende weg!

  if TempDir = '' then

  begin

    Fehler ('Tempverzeichnis kann nicht ermittelt werden.');

    exit

  end;

  TempDir := TempDir + '\';

  ProgDir := ExtractFilePath (Application.Exename);

  // Datei aus dem Internet holen.

  fs := TFileStream.Create (TempDir + fIniName, fmCreate or fmShareExclusive);

  try

    fIdHTTP.Get (fUpdateURL + fIniName, fs);

  finally

    fs.Free;

  end;

  // Werte für Version auslesen

  ini := TIniFile.Create (TempDir + IniName);

  ma := ini.ReadInteger ('Version', 'Major', 0);

  mi := ini.ReadInteger ('Version', 'Minor', 0);

  re := ini.ReadInteger ('Version', 'Release', 0);

  bu := ini.ReadInteger ('Version', 'Build', 0);

  // Direktes Update oder nicht?

  fDirektesUpdate := ini.ReadBool ('Einstellungen', 'DirektesUpdate', false);

  // Dateinamen, die runtergeladen werden sollen, auslesen.

  i := 0;

  repeat

    SetLength (fDateien, Length(fDateien)+1);

    with fDateien[i] do

    begin

      name := ini.ReadString ('Datei'+null(i+1, 3), 'Name', '');

      if ini.ReadBool ('Datei'+null(i+1, 3), 'Temp', true) then

        pfad := TempDir

      else

        Pfad := ProgDir + ini.ReadString ('Datei'+null(i+1, 3), 'Pfad', '');

    end;

    i := i + 1;

  until fDateien[i-1].name = '';

  SetLength (fDateien, Length (fDateien)-1);

  ini.Free;

  // What's New Liste, erstmal, nur füllen.

  fWhatsNewListe.LoadFromFile (TempDir + IniName);

  if FileExists (TempDir + IniName) then

    DeleteFile (TempDir + IniName); // den brauchen wir jetzt nicht mehr.

  // Remote und lokale Version zerlegen und vergleichen.

  rv := null (ma, 10) + null (mi, 10) + null(re, 10) + null(bu, 10);

  fNeueVersion := null (ma, 1) + '.' + null (mi, 1) + null(re, 1) + '.' + null(bu, 1);

  lv := FileVersionInfo (Application.ExeName).FileVersionOriginal;

  ma := StrToInt (copy(lv, 1, pos('.',lv)-1));

  delete (lv, 1, pos('.', lv));

  mi := StrToInt (copy(lv, 1, pos('.',lv)-1));

  delete (lv, 1, pos('.', lv));

  re := StrToInt (copy(lv, 1, pos('.',lv)-1));

  delete (lv, 1, pos('.', lv));

  bu := StrToInt (lv);

  lv := null (ma, 10) + null (mi, 10) + null(re, 10) + null(bu, 10);

  if rv <= lv then

    exit;

  while ((fWhatsNewListe.count > 0) and

         (UpperCase(fWhatsNewListe[0]) <> '[NEUERUNGEN]')) do

    fWhatsNewListe.Delete (0);

  if fWhatsNewListe.count > 0 then

    fWhatsNewListe.Delete (0); // das eigentliche [Neuerungen] raus!

  runterladen := false;

  if Assigned (OnUpdateGefunden) then

    OnUpdateGefunden (self, Runterladen);

  if not runterladen then exit;

  fNaechsteDatei := 0;

  DownloadStart;

end;

end.