Systemressourcen erschöpft beim VirtualStringTree.AfterCellPaint

[Hobbycoder]

Im Rahmen einer Planungssoftware stelle ich RTF-Text formatierte Text in einer Spalte eines VirtualStringTree dar.

Die Daten werden im Objekt in einem MemoryStream gespeichert. Weiterhin hat das Object ein TPicture, wo ich in die Bitmap mir das Bild für die Anzeige im VST ablegen. Während des Ladevorgangs wird also ein JvRichEdit erzeugt, dort wird aus dem Stream die RTF-Information geladen, mittels TJvRichEdit.SaveToImage das RTF in das TPicture ausgegeben und das JvRichEdit anschließen wieder gelöscht. Soweit kein Problem.

Im AfterCellPaint sieht's dann so aus:

Delphi-Quellcode:

procedure TfrmMain.vstTermineAfterCellPaint(Sender: TBaseVirtualTree;
    TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect:
    TRect);
  procedure AddSymbol(SymbolIndex: Integer; AddText: string; var DestBMP: TBitmap);
  var
    bmp: TBitmap;
    textwidth: Integer;
    textleft: Integer;
    destleft: Integer;
  begin
    bmp:=TBitmap.Create;
    try
      ilInformation.GetBitmap(SymbolIndex, bmp);
      if AddText<>'' then
      begin
        bmp.Canvas.Font.Size:=vstTermine.Font.Size;
        bmp.Canvas.Font.Style:=[fsBold];
        textwidth:=bmp.Canvas.TextWidth(AddText);
        textleft:=bmp.Width;
        bmp.Width:=bmp.Width+textwidth+4;
        bmp.Canvas.TextOut(textleft+2, Trunc((bmp.Height-bmp.Canvas.TextHeight(AddText))/2), AddText);
      end;
      destleft:=DestBMP.Width;
      DestBMP.Width:=DestBMP.Width+bmp.Width;  //<--- Manchmal tritt der Fehler hier auf
      BitBlt(DestBMP.Canvas.Handle, Destleft, 0, bmp.Width, bmp.Height, bmp.Canvas.Handle, 0, 0, SRCCOPY);
    finally
      bmp.Free;
    end;
  end;
var
  t: TTermin;
  bmp: TBitmap;
begin
  t:=TTermin(vstTermine.GetNodeData(Node)^);
  if Assigned(t) then
  begin
    case Column of
      11:          begin
          if t.RTFTextList.Items(ttArbeiten)<>Nil then
          begin
            top:=Trunc((CellRect.Height-t.RTFTextList.Items(ttArbeiten).pic.Bitmap.Height)/2);
            BitBlt(TargetCanvas.Handle, CellRect.Left, CellRect.Top+top, CellRect.Width, CellRect.Height, t.RTFTextList.Items(ttArbeiten).pic.Bitmap.Canvas.Handle, 0, 0, SRCAND);  //<---- Manchmal aber auch hier
          end;
          bmp:=TBitmap.Create;
          bmp.Height:=ilInformation.Height;
          bmp.Width:=0;
          try
          try
            if t.TB then AddSymbol(SymTB, '', bmp);
            if t.TD then AddSymbol(SymTD, '', bmp);
            if t.FD then AddSymbol(SymFD, '', bmp);
            if t.HB then AddSymbol(SymHB, '', bmp);
            if t.PlainTextList.Items(ttBemerkung)<>nil then
              if t.PlainTextList.Items(ttBemerkung).text<>'' then
                AddSymbol(SymBemerkung, '', bmp);
            if t.REgeschrieben then AddSymbol(SymRE, '', bmp);
            if t.dmsAuftragNr<>'' then AddSymbol(SymAB, '', bmp);
            top:=Trunc((CellRect.Height-bmp.Height)/2);
            BitBlt(TargetCanvas.Handle, CellRect.Left+CellRect.Width-bmp.Width, CellRect.Top+top, bmp.Width, bmp.Height, bmp.Canvas.Handle, 0, 0, SRCCOPY);
          finally
            bmp.Free;
          end;
        end;
    end;
  end;
end;

Der Fehler tritt nicht regelmäßig auf. Aber doch sooft, dass nicht wirklich damit arbeiten kann. Die Objekte sind alle das, das habe ich geprüft.
Vor allem der Fehler in der Procedure AddSymbol, wo das Bitmap für die überlagerten Symbol gezeichnet wird, sollte doch eigentlich nicht auftreten.

Hat jemand eine Idee, wie ich dem Fehler auf die Spurkommen kann.
Bild vom MADExcept habe ich mal als Anhang beigefügt.