Thread Exception beim laden von Thumbnails

[ts_abc]

Hallo,
ich habe ein Problem bei diesem Thread er Produziert eine Exception, aber nur wenn kein Thumb geladen werden kann da das Bild, Video... nicht vorhanden ist. Ich starte beim laden der Form einen Thread der alle Thumbnails nach und nach in einen TListView auf der Form aktualiesiert.

Wenn z.B. die Datei nicht vorhanden ist soll ein aus einer Ressource geladener Thumb angezeigt werden, dieser wird zu Beginn im Create des Thread in eine erstellte Bitmap Variable zur Verfügung gestellt.

Wenn alle Dateien vorhanden sind läuft alles wie erwartet ohne Probleme, so bald aber zwei Dateien aufeinander fehlen Rumst es. Dabei wird bei der ersten fehlenden Datei der Thumb noch angezeigt, bei der zweiten fehlt er schon. Das komische ist wenn ich hinter FEvent.WaitFor; in Execute ein Sleep(150); einbaue verbessert sich das ganze erheblich, fast immer geht er dann durch es rumst dann nur noch selten.

Der Debugger gibt verschiedene Exceptions aus beim ersten Mal EOutOfResources 'Systemressourcen erschöpft', dann noch beim erneuten Aufruf der Form EOutOfResources 'Das Handle ist ungültig'.
Die gute Frage ist nun wie bekomme ich jetzt raus warum es rumst und wo?

Thumbnail Thread:

Delphi-Quellcode:

unit AnPSThread;

interface

uses
  System.Generics.Collections, System.Classes, System.SyncObjs, Vcl.Graphics,
  AnPSFuncClass, AnPSThumbN;

type
  TAnThumbEvent = procedure(Sender: TObject; aWS: Pointer) of object;
  TBuildType = (btImg48Thumb, btFullThumb);
  TAnThumbParam = record
    iWS: Pointer;
    PFile: String;
    BuildType: TBuildType;
    constructor Create(aPFile: String; aWS: Pointer;
      aBuildType: TBuildType);
  end;

  TAnThumbThread = class(TThread)
  private
    FEvent: TEvent;
    FInputCS: TCriticalSection;
    FOutputCS: TCriticalSection;
    FInputQueue: TQueue<TAnThumbParam>;
    FFileThumb: TFileThumb;
    FOutput: TBitmap;
    FOnOutputChanged: TAnThumbEvent;
    FNoFile: TBitmap;
    procedure SetOutput(const Value: TBitmap);
    procedure SetOnOutputChanged(const Value: TAnThumbEvent);
    function GetOnOutputChanged: TAnThumbEvent;
    procedure DoOutputChanged(aWS: PWorkStateItem);
  protected
    procedure Execute; override;
    procedure TerminatedSet; override;
    function GetThumbParam: TAnThumbParam;
    procedure DoExecute;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Add(AThumbParam: TAnThumbParam);
    procedure Get(ABitmap: TBitmap);

    property OnOutputChanged: TAnThumbEvent read GetOnOutputChanged write SetOnOutputChanged;
  end;

implementation

uses System.SysUtils;

{ TAnThumbParam }

constructor TAnThumbParam.Create(aPFile: String; aWS: Pointer;
  aBuildType: TBuildType);
begin
  iWS := aWS;
  PFile := aPFile;
  BuildType := aBuildType;
end;

{ TAnThumbThread }

procedure TAnThumbThread.Add(AThumbParam: TAnThumbParam);
begin
  FInputCS.Enter;
  try
    FInputQueue.Enqueue(AThumbParam);
    FEvent.SetEvent;
  finally
    FInputCS.Leave;
  end;
end;

constructor TAnThumbThread.Create;
begin
  FInputCS := TCriticalSection.Create;
  FOutputCS := TCriticalSection.Create;
  FEvent := TEvent.Create(nil, True, False, '');
  FInputQueue := TQueue<TAnThumbParam>.Create;
  FFileThumb := TFileThumb.Create;
  FFileThumb.Size := 256;
  FOutput := TBitmap.Create;
  FNoFile := TBitmap.Create;
  FNoFile.LoadFromResourceName(hInstance, 'NoFileFound');
  FNoFile.Transparent := True;
  inherited Create;
end;

destructor TAnThumbThread.Destroy;
begin
  inherited;
  FInputQueue.Free;
  FOutput.Free;
  FNoFile.Free;
  FFileThumb.Free;
  FOutputCS.Free;
  FInputCS.Free;
  FEvent.Free;
end;

procedure TAnThumbThread.DoExecute;
var tBmp, tmpBmp: TBitmap; iPic: String; LParams: TAnThumbParam;
begin
  // Parameter aus Queue holen
  LParams := GetThumbParam;

  tBmp := TBitmap.Create;
  tmpBmp := TBitmap.Create;
  try
    // Thumb erstellen
    tBmp.Canvas.Lock;
    FNoFile.Canvas.Lock;
    tmpBmp.Canvas.Lock;
    try
      if LParams.BuildType = btImg48Thumb then
        if FFileThumb.Size <> 128 then FFileThumb.Size := 128
      else
        if FFileThumb.Size <> 256 then FFileThumb.Size := 256;
      iPic := LParams.PFile;

      if (iPic = '') or (not FileExists(iPic)) then begin
        tmpBmp.Assign(FNoFile);
        tmpBmp.Transparent := True;
      end else begin
        FFileThumb.FilePath := iPic;
        tmpBmp.Assign(FFileThumb.ThumbBmp);
      end;
      AddThumbToOutBmp(tmpBmp, tBmp);
    finally
      tBmp.Canvas.Unlock;
      FNoFile.Canvas.Unlock;
      tmpBmp.Canvas.Unlock;
    end;

    // Thumb in die Ausgabe schreiben
    SetOutput(tBmp);

  finally
    tBmp.Free;
    tmpBmp.Free;
  end;

  // Benachrichtigen
  Synchronize(
    procedure begin
      DoOutputChanged(LParams.iWS);
    end);
end;

procedure TAnThumbThread.DoOutputChanged(aWS: PWorkStateItem);
var LEvent: TAnThumbEvent;
begin
  LEvent := OnOutputChanged;
  if Assigned(LEvent) then LEvent(Self, aWS);
end;

procedure TAnThumbThread.Execute;
begin
  inherited;
  while not Terminated do begin
    FEvent.WaitFor;
    //Sleep(150);
    if not Terminated then DoExecute;
  end;
end;

procedure TAnThumbThread.Get(ABitmap: TBitmap);
begin
  FOutputCS.Enter;
  try
    if Assigned(FOutput) then ABitmap.Assign(FOutput);
  finally
    FOutputCS.Leave;
  end;
end;

function TAnThumbThread.GetThumbParam: TAnThumbParam;
begin
  FInputCS.Enter;
  try
    Result := FInputQueue.Dequeue;
    if (FInputQueue.Count = 0) and not Terminated then FEvent.ResetEvent;
  finally
    FInputCS.Leave;
  end;
end;

function TAnThumbThread.GetOnOutputChanged: TAnThumbEvent;
begin
  FOutputCS.Enter;
  try
    Result := FOnOutputChanged;
  finally
    FOutputCS.Leave;
  end;
end;

procedure TAnThumbThread.SetOnOutputChanged(const Value: TAnThumbEvent);
begin
  FOutputCS.Enter;
  try
    FOnOutputChanged := Value;
  finally
    FOutputCS.Leave;
  end;
end;

procedure TAnThumbThread.SetOutput(const Value: TBitmap);
begin
  FOutputCS.Enter;
  try
    FOutput.Assign(Value);
  finally
    FOutputCS.Leave;
  end;
end;

procedure TAnThumbThread.TerminatedSet;
begin
  inherited;
  FEvent.SetEvent;
end;

end.

Form:

Delphi-Quellcode:

procedure TForm2.BeforeDestruction;
begin
  inherited;
  FThumbThread.OnOutputChanged := nil;
  FThumbThread.Free;
end;

// Benachrichtigung vom Thread, Thumb in ListView aktualisieren
procedure TForm2.ThumbOutputChanged(Sender: TObject;
  aWS: Pointer);
var idx: Integer; iLV: TListItem; r: Cardinal;
begin
  iLV := nil;
  ThumbBmp.Canvas.Lock;
  try
    FThumbThread.Get(ThumbBmp);
    try
      AddPointToThumb(ThumbBmp, aWS);
      idx := ImageList1.AddMasked(ThumbBmp, clFuchsia);
      iLV := ListView1.FindData(0, aWS, True, False);
      if Assigned(iLV) then iLV.ImageIndex := idx;
    finally
    end;
  finally
    ThumbBmp.Canvas.Unlock;
  end;
end;

procedure TForm2.FormCreate(Sender: TObject);
var i: Integer;
begin
  FThumbThread := TAnThumbThread.Create;
  FThumbThread.OnOutputChanged := ThumbOutputChanged;

  InitializeWS;
end;

// Abzuarbeitende Thumbs übergeben
procedure TForm2.InitializeWS;
var i: Integer; iWS: Pointer; iLV: TListItem;
begin
  ListView1.Items.BeginUpdate;
  try
    ListView1.Clear;
    for i:=0 to FSModul.FS_Out_WSData.Count - 1 do begin
      iWS := FSModul.FS_Out_WSData[i];
      ...

      iLV := ListView1.Items.Add;
      iLV.Data := iWS;
      iLV.Caption := iWS^.Name;
      iLV.ImageIndex := -1;
      FThumbThread.Add(TAnThumbParam.Create(iWS^.Dir+iWS^.Name, iWS,
        btImg48Thumb));
    end;
  finally
    ListView1.Items.EndUpdate;
  end;
end;