![]() |
BackgroundWorker [ab XE2]
In der letzten Zeit konnte man einige Fragen im Forum zum Thema Multi-Threading finden, bzw. solche, die sich erheblich besser mit einem separaten Thread erledigen lassen würden.
Unter .Net findet man den ![]() Der Code ist getestet mit Delphi XE8 sollte aber ohne Änderungen ab Delphi XE2 laufen. Für ältere Delphi-Versionen dürften die Anpassungen recht simpel sein, da das Prinzip selber simpel ist, diese werde ich aber nicht vornehmen. Auch ist es möglich daraus ein Package zu bilden um diesen BackgroundWorker direkt auf eine Form zu klatschen, das überlasse ich allerdings jedem Einzelnen :) Beispiele zur Verwendung folgen als separate Beiträge in diesem Thread, hier erst mal der Code selber:
Delphi-Quellcode:
unit BackgroundWorker;
interface uses System.Classes, System.Rtti, System.SysUtils; {$REGION 'EventArgs'} type TProgressChangedEventArgs = class private FPercentProgress: Integer; FUserState: TValue; public constructor Create( APercentProgress: Integer; AUserState: TValue ); property PercentProgress: Integer read FPercentProgress; property UserState: TValue read FUserState; end; TDoWorkEventArgs = class private FArgument: TValue; FCancel: Boolean; FResult: TValue; public constructor Create( AArgument: TValue ); property Argument: TValue read FArgument; property Cancel: Boolean read FCancel write FCancel; property Result: TValue read FResult write FResult; end; TRunWorkerCompletedEventArgs = class private FCancelled: Boolean; FError: Exception; FResult: TValue; public constructor Create( AResult: TValue; AError: Exception; ACancelled: Boolean ); property Cancelled: Boolean read FCancelled; property Error: Exception read FError; property Result: TValue read FResult; end; {$ENDREGION} {$REGION 'Events'} type TBackgroundWorkerProgressChangedEvent = procedure( Sender: TObject; e: TProgressChangedEventArgs ) of object; TBackgroundWorkerDoWorkEvent = procedure( Sender: TObject; e: TDoWorkEventArgs ) of object; TBackgroundWorkerRunWorkerCompletedEvent = procedure( Sender: TObject; e: TRunWorkerCompletedEventArgs ) of object; {$ENDREGION} {$REGION 'CustomBackgroundWorker'} type TCustomBackgroundWorker = class( TComponent ) private FThread: TThread; FDoWorkEventArg: TDoWorkEventArgs; FCancellationRequested: Boolean; FWorkerReportsProgress: Boolean; FWorkerSupportsCancellation: Boolean; FOnDoWork: TBackgroundWorkerDoWorkEvent; FOnProgressChanged: TBackgroundWorkerProgressChangedEvent; FOnRunWorkerCompleted: TBackgroundWorkerRunWorkerCompletedEvent; function GetCancellationRequested: Boolean; procedure WorkerThreadTerminate( Sender: TObject ); function GetIsBusy: Boolean; protected procedure NotifyDoWork( e: TDoWorkEventArgs ); virtual; procedure NotifyProgressChanged( e: TProgressChangedEventArgs; ADispose: Boolean = True ); virtual; procedure NotifyRunCompleted( e: TRunWorkerCompletedEventArgs; ADispose: Boolean = True ); virtual; public procedure CancelAsync; procedure ReportProgress( PercentProgress: Integer ); overload; procedure ReportProgress( PercentProgress: Integer; UserState: TValue ); overload; procedure RunWorkerAsync; overload; procedure RunWorkerAsync<T>( Argument: T ); overload; procedure RunWorkerAsync( Argument: TValue ); overload; property CancellationRequested: Boolean read GetCancellationRequested; property IsBusy: Boolean read GetIsBusy; protected property OnDoWork: TBackgroundWorkerDoWorkEvent read FOnDoWork write FOnDoWork; property OnProgressChanged: TBackgroundWorkerProgressChangedEvent read FOnProgressChanged write FOnProgressChanged; property OnRunWorkerCompleted: TBackgroundWorkerRunWorkerCompletedEvent read FOnRunWorkerCompleted write FOnRunWorkerCompleted; public property WorkerReportsProgress: Boolean read FWorkerReportsProgress write FWorkerReportsProgress; property WorkerSupportsCancellation: Boolean read FWorkerSupportsCancellation write FWorkerSupportsCancellation; end; {$ENDREGION} {$REGION 'TBackgroundWorker'} type TBackgroundWorker = class( TCustomBackgroundWorker ) published property OnDoWork; property OnProgressChanged; property OnRunWorkerCompleted; property WorkerReportsProgress; property WorkerSupportsCancellation; end; {$ENDREGION} implementation {$REGION 'Ressourcestrings'} resourcestring SWorkerDoesNotSupportsCancellation = 'Worker does not supports cancellation'; SWorkerDoesNotReportsProgress = 'Worker does not reports progress'; SWorkerIsBusy = 'Worker is busy'; {$ENDREGION} {$REGION 'EventArgs'} { TProgressChangedEventArgs } constructor TProgressChangedEventArgs.Create( APercentProgress: Integer; AUserState: TValue ); begin inherited Create; FPercentProgress := APercentProgress; FUserState := AUserState; end; { TDoWorkEventArgs } constructor TDoWorkEventArgs.Create( AArgument: TValue ); begin inherited Create; FArgument := AArgument; end; { TRunWorkerCompletedEventArgs } constructor TRunWorkerCompletedEventArgs.Create( AResult: TValue; AError: Exception; ACancelled: Boolean ); begin inherited Create; FCancelled := ACancelled; FError := AError; FResult := AResult; end; {$ENDREGION} {$REGION 'TCustomBackgroundWorker'} { TCustomBackgroundWorker } procedure TCustomBackgroundWorker.CancelAsync; begin if not WorkerSupportsCancellation then raise EInvalidOpException.Create( SWorkerDoesNotSupportsCancellation ); FCancellationRequested := True; end; procedure TCustomBackgroundWorker.ReportProgress( PercentProgress: Integer ); begin ReportProgress( PercentProgress, TValue.Empty ); end; function TCustomBackgroundWorker.GetCancellationRequested: Boolean; begin Result := ( csDestroying in ComponentState ) or FCancellationRequested; end; function TCustomBackgroundWorker.GetIsBusy: Boolean; begin Result := Assigned( FThread ); end; procedure TCustomBackgroundWorker.NotifyDoWork( e: TDoWorkEventArgs ); begin if Assigned( FOnDoWork ) then FOnDoWork( Self, e ); end; procedure TCustomBackgroundWorker.NotifyProgressChanged( e: TProgressChangedEventArgs; ADispose: Boolean ); begin if not( csDestroying in ComponentState ) then TThread.Queue( nil, procedure begin try if Assigned( FOnProgressChanged ) then FOnProgressChanged( Self, e ); finally if ADispose then e.Free; end; end ) else begin if ADispose then e.Free; end; end; procedure TCustomBackgroundWorker.NotifyRunCompleted( e: TRunWorkerCompletedEventArgs; ADispose: Boolean ); begin try if not( csDestroying in ComponentState ) then if Assigned( FOnRunWorkerCompleted ) then FOnRunWorkerCompleted( Self, e ); finally if ADispose then e.Free; end; end; procedure TCustomBackgroundWorker.ReportProgress( PercentProgress: Integer; UserState: TValue ); begin if not WorkerReportsProgress then raise EInvalidOpException.Create( SWorkerDoesNotReportsProgress ); NotifyProgressChanged( TProgressChangedEventArgs.Create( PercentProgress, UserState ) ); end; procedure TCustomBackgroundWorker.RunWorkerAsync; begin RunWorkerAsync( TValue.Empty ); end; procedure TCustomBackgroundWorker.RunWorkerAsync( Argument: TValue ); begin if IsBusy then raise EInvalidOpException.Create( SWorkerIsBusy ); FCancellationRequested := False; FDoWorkEventArg := TDoWorkEventArgs.Create( Argument ); FThread := TThread.CreateAnonymousThread( procedure begin NotifyDoWork( FDoWorkEventArg ); end ); FThread.OnTerminate := WorkerThreadTerminate; FThread.Start; end; procedure TCustomBackgroundWorker.RunWorkerAsync<T>( Argument: T ); begin RunWorkerAsync( TValue.From<T>( Argument ) ); end; procedure TCustomBackgroundWorker.WorkerThreadTerminate( Sender: TObject ); var LThread: TThread; LDoWorkEventArg: TDoWorkEventArgs; begin LThread := FThread; LDoWorkEventArg := FDoWorkEventArg; FThread := nil; FDoWorkEventArg := nil; try if Assigned( LThread.FatalException ) then NotifyRunCompleted( TRunWorkerCompletedEventArgs.Create( TValue.Empty, LThread.FatalException as Exception, False ) ) else NotifyRunCompleted( TRunWorkerCompletedEventArgs.Create( LDoWorkEventArg.Result, nil, LDoWorkEventArg.Cancel ) ); finally FreeAndNil( LDoWorkEventArg ); end; end; {$ENDREGION} end. |
AW: BackgroundWorker [ab XE2]
Liste der Anhänge anzeigen (Anzahl: 1)
![]() (Source und EXE im Anhang)
Delphi-Quellcode:
unit Form.Main;
interface uses BackgroundWorker, System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, FMX.Controls.Presentation, FMX.Layouts; type TService = class( TComponent ) private FIsRunning: Boolean; public procedure Activate; procedure Deactivate; property IsRunning: Boolean read FIsRunning; end; TForm1 = class( TForm ) Layout1: TLayout; Switch1: TSwitch; Label1: TLabel; AniIndicator1: TAniIndicator; procedure Switch1Switch( Sender: TObject ); procedure FormShow( Sender: TObject ); private FService: TService; FServiceWorker: TBackgroundWorker; procedure ServiceWorkerDoWork( Sender: TObject; e: TDoWorkEventArgs ); procedure ServiceWorkerRunCompleted( Sender: TObject; e: TRunWorkerCompletedEventArgs ); public procedure AfterConstruction; override; end; var Form1: TForm1; implementation {$R *.fmx} { TForm1 } procedure TForm1.AfterConstruction; begin inherited; // Service-Instanz FService := TService.Create( Self ); // Der Service-EinAusSchalter FServiceWorker := TBackgroundWorker.Create( Self ); FServiceWorker.OnDoWork := ServiceWorkerDoWork; FServiceWorker.OnRunWorkerCompleted := ServiceWorkerRunCompleted; end; procedure TForm1.FormShow( Sender: TObject ); begin Switch1.IsChecked := FService.IsRunning; end; procedure TForm1.ServiceWorkerDoWork( Sender: TObject; e: TDoWorkEventArgs ); begin if e.Argument.AsBoolean then FService.Activate else FService.Deactivate; end; procedure TForm1.ServiceWorkerRunCompleted( Sender: TObject; e: TRunWorkerCompletedEventArgs ); begin AniIndicator1.Visible := False; Switch1.Visible := True; Switch1.IsChecked := FService.IsRunning; end; procedure TForm1.Switch1Switch( Sender: TObject ); begin Switch1.Visible := False; AniIndicator1.Visible := True; FServiceWorker.RunWorkerAsync( Switch1.IsChecked ); end; { TService } procedure TService.Activate; begin if not FIsRunning then begin Sleep( 1000 ); case Random( 2 ) of 1: raise Exception.Create( 'Fehlermeldung' ); end; FIsRunning := True; end; end; procedure TService.Deactivate; begin if FIsRunning then begin Sleep( 500 ); FIsRunning := False; end; end; end. |
AW: BackgroundWorker [ab XE2]
Liste der Anhänge anzeigen (Anzahl: 1)
![]() (Source und EXE im Anhang)
Delphi-Quellcode:
unit Form.Main;
interface uses BackgroundWorker, Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.ExtCtrls, Data.DB, FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Param, FireDAC.Stan.Error, FireDAC.DatS, FireDAC.Phys.Intf, FireDAC.DApt.Intf, FireDAC.Comp.DataSet, FireDAC.Comp.Client, System.Actions, Vcl.ActnList, Vcl.ToolWin, Vcl.Grids, Vcl.DBGrids; type TForm1 = class( TForm ) DBGrid1: TDBGrid; ToolBar1: TToolBar; ProgressBar1: TProgressBar; ToolButton1: TToolButton; ActionList1: TActionList; GetDataAction: TAction; DataSource1: TDataSource; Label1: TLabel; ToolButton2: TToolButton; ToolButton3: TToolButton; CancelAction: TAction; GetDataExceptionAction: TAction; procedure GetDataActionExecute( Sender: TObject ); procedure GetDataActionUpdate( Sender: TObject ); procedure CancelActionExecute( Sender: TObject ); procedure CancelActionUpdate( Sender: TObject ); procedure GetDataExceptionActionExecute( Sender: TObject ); procedure GetDataExceptionActionUpdate( Sender: TObject ); private FGetDataWorker: TBackgroundWorker; FDataTable: TFDMemTable; procedure StartDataWorker( AValue: Integer ); procedure GetDataWorkerDoWork( Sender: TObject; e: TDoWorkEventArgs ); procedure GetDataWorkerRunWorkerCompleted( Sender: TObject; e: TRunWorkerCompletedEventArgs ); public procedure AfterConstruction; override; procedure BeforeDestruction; override; end; var Form1: TForm1; implementation uses Unit2; {$R *.dfm} procedure TForm1.AfterConstruction; begin inherited; FGetDataWorker := TBackgroundWorker.Create( Self ); FGetDataWorker.OnDoWork := GetDataWorkerDoWork; FGetDataWorker.OnRunWorkerCompleted := GetDataWorkerRunWorkerCompleted; FGetDataWorker.WorkerReportsProgress := False; FGetDataWorker.WorkerSupportsCancellation := True; end; procedure TForm1.BeforeDestruction; begin inherited; FreeAndNil( FDataTable ); end; procedure TForm1.CancelActionExecute( Sender: TObject ); begin FGetDataWorker.CancelAsync( ); end; procedure TForm1.CancelActionUpdate( Sender: TObject ); begin TAction( Sender ).Enabled := FGetDataWorker.IsBusy and FGetDataWorker.WorkerSupportsCancellation and not FGetDataWorker.CancellationRequested; end; procedure TForm1.GetDataActionExecute( Sender: TObject ); begin StartDataWorker( 0 ); end; procedure TForm1.GetDataActionUpdate( Sender: TObject ); begin TAction( Sender ).Enabled := not FGetDataWorker.IsBusy; end; procedure TForm1.GetDataExceptionActionExecute( Sender: TObject ); begin StartDataWorker( 1 ); end; procedure TForm1.GetDataExceptionActionUpdate( Sender: TObject ); begin TAction( Sender ).Enabled := not FGetDataWorker.IsBusy; end; procedure TForm1.GetDataWorkerDoWork( Sender: TObject; e: TDoWorkEventArgs ); begin Sleep( 500 ); if TBackgroundWorker( Sender ).CancellationRequested then begin e.Cancel := True; Exit; end; Sleep( 2000 ); if TBackgroundWorker( Sender ).CancellationRequested then begin e.Cancel := True; Exit; end; // Ab jetzt kann nicht mehr abgebrochen werden Sleep( 1000 ); case e.Argument.AsInteger of 0: e.Result := TFDMemTable.Create( nil ); 1: raise Exception.Create( 'Irgendeine Fehlermeldung' ); end; end; procedure TForm1.GetDataWorkerRunWorkerCompleted( Sender: TObject; e: TRunWorkerCompletedEventArgs ); begin ProgressBar1.Visible := False; if Assigned( e.Error ) then begin Label1.Visible := True; Label1.Caption := e.Error.ToString( ); end else begin if e.Cancelled then begin Label1.Visible := True; Label1.Caption := 'Cancelled'; end else begin FDataTable := e.Result.AsType<TFDMemTable>; DataSource1.DataSet := FDataTable; DBGrid1.Visible := True; end; end; end; procedure TForm1.StartDataWorker( AValue: Integer ); begin // Altes Ergebnis löschen FreeAndNil( FDataTable ); Label1.Visible := False; DBGrid1.Visible := False; ProgressBar1.Visible := True; ProgressBar1.Style := TProgressBarStyle.pbstMarquee; // BackgroundWorker starten FGetDataWorker.RunWorkerAsync( AValue ); end; end. |
AW: BackgroundWorker [ab XE2]
Und hier noch ein kommentiertes Beispiel
Delphi-Quellcode:
unit Unit3;
interface uses BackgroundWorker, Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Actions, Vcl.ActnList, Vcl.ComCtrls, Vcl.StdCtrls; type TForm3 = class( TForm ) ActionList1: TActionList; RunAction: TAction; CancelAction: TAction; ProgressBar1: TProgressBar; ProgressInfoLabel: TLabel; Button1: TButton; Button2: TButton; procedure RunActionExecute( Sender: TObject ); procedure CancelActionExecute( Sender: TObject ); procedure CancelActionUpdate( Sender: TObject ); procedure RunActionUpdate( Sender: TObject ); private FWorker: TBackgroundWorker; procedure WorkerDoWork( Sender: TObject; e: TDoWorkEventArgs ); procedure WorkerProgressChanged( Sender: TObject; e: TProgressChangedEventArgs ); procedure WorkerRunWorkerCompleted( Sender: TObject; e: TRunWorkerCompletedEventArgs ); public procedure AfterConstruction; override; end; var Form3: TForm3; implementation {$R *.dfm} { TForm3 } procedure TForm3.CancelActionExecute( Sender: TObject ); begin FWorker.CancelAsync( ); end; procedure TForm3.CancelActionUpdate( Sender: TObject ); begin // Abbrechen ist nur möglich/sinnvoll, wenn // - der Worker läuft // - der Worker das Abbrechen unterstützt // - der Worker noch nicht zum Abbrechen aufgefordert wurde TAction( Sender ).Enabled := FWorker.IsBusy and FWorker.WorkerSupportsCancellation and not FWorker.CancellationRequested; end; procedure TForm3.RunActionExecute( Sender: TObject ); begin // Darstellung vorbereiten ProgressInfoLabel.Caption := 'läuft...'; ProgressBar1.Style := TProgressBarStyle.pbstMarquee; // Worker starten FWorker.RunWorkerAsync( 'Argument' ); end; procedure TForm3.RunActionUpdate( Sender: TObject ); begin // Der Worker kann nur gestartet werden, wenn der aktuell nicht läuft TAction( Sender ).Enabled := not FWorker.IsBusy; end; procedure TForm3.AfterConstruction; begin inherited; FWorker := TBackgroundWorker.Create( Self ); // Eventhandler zuweisen FWorker.OnDoWork := WorkerDoWork; // Das läuft im Thread FWorker.OnProgressChanged := WorkerProgressChanged; FWorker.OnRunWorkerCompleted := WorkerRunWorkerCompleted; // Einstellungen setzen FWorker.WorkerReportsProgress := True; end; procedure TForm3.WorkerDoWork( Sender: TObject; e: TDoWorkEventArgs ); var LArgument: string; LIdx: Integer; begin // Dieser Teil kann abgebrochen werden TBackgroundWorker( Sender ).WorkerSupportsCancellation := True; // Argument vom Aufruf LArgument := e.Argument.ToString( ); // Wir warten mal ein Weilchen Sleep( 500 ); // Arbeit simulieren for LIdx := 1 to 100 do begin // Auf Abbruchanforderung prüfen if TBackgroundWorker( Sender ).CancellationRequested then begin e.Cancel := True; // Ja, wir haben die Verarbeitung abgebrochen Exit; // raus hier end; Sleep( 10 ); // Fortschritt mitteilen TBackgroundWorker( Sender ).ReportProgress( {PercentProgress} LIdx, {UserState} Format( 'Satz: %d', [ LIdx ] ) ); end; // Ab jetzt kann nicht mehr abgebrochen werden TBackgroundWorker( Sender ).WorkerSupportsCancellation := False; Sleep( 1000 ); // Ergebnis übergeben e.Result := 'Result: ' + LArgument; end; procedure TForm3.WorkerProgressChanged( Sender: TObject; e: TProgressChangedEventArgs ); begin ProgressBar1.Style := TProgressBarStyle.pbstNormal; ProgressBar1.Position := e.PercentProgress; ProgressInfoLabel.Caption := e.UserState.ToString( ); end; procedure TForm3.WorkerRunWorkerCompleted( Sender: TObject; e: TRunWorkerCompletedEventArgs ); begin if Assigned( e.Error ) then // Es gab einen Fehler ProgressInfoLabel.Caption := e.Error.ToString( ) else if e.Cancelled then // oder es wurde abgebrochen ProgressInfoLabel.Caption := 'abgebrochen' else // oder die Aufgabe wurde komplett abgearbeitet ProgressInfoLabel.Caption := e.Result.ToString( ); end; end. |
AW: BackgroundWorker [ab XE2]
:thumb:
Für alle vor XE gabs noch diesen: ![]() und jenen ![]() |
AW: BackgroundWorker [ab XE2]
Hallo,
ich bin eher ein starker Forum-Leser :) .. aber diesmal ich mal Lob für Sir Rufo aussprechen. Sind immer super antworten und dieser Thread hat mein Wissen wieder deutlich erweitert. Toll! :thumb: :thumb: Ich weiß zwar nicht woher die Motivation kommt, aber TOLL!!! |
AW: BackgroundWorker [ab XE2]
...kann mich meinem Vorredner nur anschließen!
:cheers: |
AW: BackgroundWorker [ab XE2]
Wenn wir schon dabei sind: Ich muss mich auch als Sir Rufo Fan outen. :thumb:
Die Erklärungen sowie Beispielcodes sind stets gut verständlich und sehr ausführlich. Ich konnte mir bereits viel abschauen und werde wohl auch in Zukunft noch sehr viel lernen. Vielen Dank dafür und weiter so! Edit: Solltest du dich irgendwann dazu entscheiden Programmier-Kurse zu geben, dann wäre ich sofort dabei! |
AW: BackgroundWorker [ab XE2]
Zitat:
![]() |
AW: BackgroundWorker [ab XE2]
|
Alle Zeitangaben in WEZ +1. Es ist jetzt 21:55 Uhr. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz