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:

zusammenfalten · markieren

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:

zusammenfalten · markieren

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;

Soweit ich weiß, ist TBitmap nicht Thread-safe. Nicht nur in dem Sinne, dass man da beim Zugriff von verschiedenen Threads heraus vorsichtig sein muss, sondern sogar so, dass TBitmap generell nur im VCL-Hauptthread verwendet werden darf. Selbst völlig Thread-lokale Bitmaps, die nur im Kontext des Threads erstellt, bearbeitet und wieder zerstört werden, können Probleme machen.

Und wenn ich deinen Code richtig sehe, überträgst du Bitmaps über Threadgrenzen hinweg. Schön verpackt mit CriticalSections, aber soweit ich weiß, hilft das bei Bitmaps nicht.

Mm, Gausi das wäre jetzt aber wirklich doof, da hab ich aber ein echtes Problem. Denn alleine schon der vom BS zurückgegebene Thumbnail ist ein HBitmap. Das komische ist aber dass wenn nicht der Vorgefertigte Bitmap aus der Ressource verwendet wird es auch nicht kracht.

Ich glaub in dem Fall, ist noch irgendwo ein anderes Problem. Ich stelle da mal ne wage Vermutung an, ich glaub der Thread hat irgendwo ein Problem mit dem schnelleren verarbeiten des im Speicher liegenden Bitmap. Er scheint wohl irgendwo dann zu kollidieren wenn der Hauptthread noch nicht fertig ist. Im Moment kommen die Thumbnails noch von einer normalen mechanischen Festplatte und es kracht dabei nicht. Ich frag mich gerade was passiert wenn es von einer SSD kommt, ich werde das mal testen.

Windows Ressourcen sind Thread-Affin.
Sie sind nur im erzeugenden Thread gültig.
Du kannst sie nicht über Threadgrenzen hinweg übertragen.

Puh Ok, ich hoffe ich habe den Fehler gefunden, jetzt läuft alles wie es soll. Der Fehler wurde wie es aussieht ausgelöst, in der Komponente TFileThumb. Diese arbeitet ebenfalls mit einem Bitmap aus dem Grunde, da das BS einen HBitmap als Thumbnail liefert. Hierbei war natürlich kein Look, Unlook beim arbeiten mit dem BMP drin. Somit flog mir das Ganze an dieser Stelle:

zusammenfalten · markieren

Delphi-Quellcode:

procedure TAnThumbThread.DoExecute;
var tBmp, tmpBmp: TBitmap; iPic: String; LParams: TAnThumbParam;
begin
  ...
    try
      if LParams.BuildType = btImg48Thumb then
        if FFileThumb.Size <> 128 then FFileThumb.Size := 128
      else
        if FFileThumb.Size <> 256 then FFileThumb.Size := 256;

      ...
    finally
      ...
    end;

  ...
end;

um die Ohren.

@Bernhard Geyer
Ne, ich werde mich hüten das zu mach , ich übertrage es Natürlich nicht direkt sondern Zeichne es auf dem Output.

Ok Luckie Danke, aber wieso in das Thema Multimedia?