TListView - Problem mit Miniaturansichten mit OwnerData

[marcos]

Hallo,

ich habe ein Problem mit der Anzeige von Miniaturansichten in einer TListView.
TListView ist definiert als OwnerData (Virtuell) und die Miniaturansichten werden mit AdvancedCustomDrawItem gezeichnet. Das funktioniert auch wunderbar unter Vista. Unter XP dagegen werden die Bilder gezeichnet und verschwinden gleich danach. Das ist leicht nachvollziehbar in dem angehängten Testprojekt.
Vielleicht hat schon jemand was ähnliches gehabt?

Gruß
marcos

P.S.
Getestet mit D2007, D2009

[marcos]

Hi,

vielleicht hat jemand eine Idee, warum das unter XP nicht funktioniert: die Bilder erscheinen kurz und verschwinden danach.
Unter Vista - kein Problem.

Gruß
marcos

Delphi-Quellcode:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, CommCtrl, ExtCtrls, ImgList;

type TLvOnItemGetThumb = procedure(Sender:TObject; Item: TListItem; var AThumb: TBitmap) of object;

type TMyListView = class(TListView)
       private
         FDummyImgList:        TImageList;
         FThumbW:              integer;
         FThumbH:              integer;
         FThumbBorderSize:     integer;
         FThumbXSpacing:       integer;
         FThumbYSpacing:       integer;

         FOnItemGetThumb:      TLvOnItemGetThumb;

         procedure DefineCanvasColors(ACanvas: TCanvas;Item: TListItem; State: TCustomDrawState);
         procedure DrawThumb(ACanvas: TCanvas;State: TCustomDrawState; Item: TListItem; RThumb: TRect);
       protected
          procedure InternalAdvancedCustomDrawItem(Sender: TCustomListView;
                        Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
                        var DefaultDraw: Boolean);
       public

          constructor Create(AOwner: TComponent);override;
          destructor Destroy; override;

          property OnItemGetThumb: TLvOnItemGetThumb
                read FOnItemGetThumb write FOnItemGetThumb;
end;

type
  TForm1 = class(TForm)
    ImageList1: TImageList;
    Panel1: TPanel;
    ImageListThumb: TImageList;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure lvDataHint(Sender: TObject; StartIndex, EndIndex: Integer);
    procedure lvData(Sender: TObject; Item: TListItem);
    procedure lvGetThumb(Sender:TObject; Item: TListItem; var AThumb: TBitmap);
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
    FThumbLV:   TMyListView;
    FItems:     TStringList;
    FCreateNow: boolean;

  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

constructor TMyListView.Create(AOwner: TComponent);
var R: TRect;
    W, H: integer;
begin
   inherited Create(AOwner);
   if AOwner is TWinControl then
      Self.Parent := TWinControl(AOwner);

   FThumbW          := 120;
   FThumbH          := 120;
   FThumbBorderSize := 4;
   FThumbXSpacing   := 10;
   FThumbYSpacing   := 30;
   FDummyImgList       := TImageList.Create(Self);
   FDummyImgList.Width := FThumbW-16 +(2*FThumbBorderSize);
   FDummyImgList.Height:= FThumbH-4 +(2*FThumbBorderSize);

   LargeImages := FDummyImgList;
   ViewStyle   := vsIcon;

   R := Rect(0, 0, FThumbW + 2*FThumbBorderSize, FThumbH + 2*FThumbBorderSize);
   W := R.Right + FThumbXSpacing;
   H := R.Bottom + FThumbYSpacing;
   ListView_SetIconSpacing(Handle, W, H);

   MultiSelect    := true;
   OwnerData      := true;


   OnAdvancedCustomDrawItem := InternalAdvancedCustomDrawItem;
end;

destructor TMyListView.Destroy;
begin
   FDummyImgList.Free;

   inherited Destroy;
end;

procedure TMyListView.InternalAdvancedCustomDrawItem(Sender: TCustomListView;
                        Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
                        var DefaultDraw: Boolean);
var B: TBitmap;
    R, RIcon: TRect;
    W: integer;
    s: string;
begin
   if not Assigned(Item) then exit;

   Case Stage of

      cdPostPaint:
        begin
          if Assigned(FOnItemGetThumb) then begin
              B := TBitmap.Create;
              B.Canvas.Lock;
              try
                ListView_GetItemRect(Handle, Item.index, RIcon, LVIR_ICON );
                if (RIcon.Right > RIcon.Left) and (RIcon.Bottom > RIcon.Top) and
                    ((RIcon.Bottom - RIcon.Top) < Height)  then begin

                    R := Rect(0, 0, RIcon.Right - RIcon.Left, RIcon.Bottom - RIcon.Top);
                    B.Width := R.Right;
                    B.Height := R.Bottom;
                    B.Canvas.Brush.Color := Self.Color;
                    B.Canvas.Fillrect(Rect(0, 0, R.Right, R.Bottom));

                    B.Canvas.CopyRect(R, Sender.Canvas, RIcon);

                    //Thumb bkg color
                    B.Canvas.Brush.Color := Self.Color;
                    B.Canvas.FillRect(R);

                    DrawThumb(B.Canvas, State, Item,  R);

                    Sender.Canvas.Lock;
                    try
                      DefineCanvasColors(Canvas, Item, State);
                      Canvas.Brush.Style := bsSolid;
                      Sender.Canvas.Draw(RIcon.Left, RIcon.Top, B);

                      //Caption
                      ListView_GetItemRect(Handle, Item.index, R, LVIR_LABEL );
                      R.Bottom := R.Bottom- 2;
                      Windows.DrawText(Canvas.Handle, PChar(Item.Caption), -1, R, DT_CENTER);
                      //Delphi2009 Windows.DrawText(Canvas.Handle, PWideChar(Item.Caption), -1, R, DT_CENTER);
                      //DefaultDraw := false;
                    finally
                      Sender.Canvas.UnLock;
                    end;
                    DefaultDraw := false;
                end;
              finally
                B.Canvas.UnLock;
                B.Free;
              end;
          end;

        end;
   End;

end;

procedure TMyListView.DefineCanvasColors(ACanvas: TCanvas;Item: TListItem; State: TCustomDrawState);
begin
    if Item.Selected then begin
          ACanvas.Brush.Color := clHighlight;
          ACanvas.Font.Color  := clHighlightText;
          if cdsHot in State then
             ACanvas.Font.Color  := clActiveCaption;
    end
    else if Item.Focused then begin
          ACanvas.Brush.Color := clHighlight;
          ACanvas.Font.Color  := clHighlightText;
    end
    else if cdsHot in State then begin
          ACanvas.Brush.Color := clHotLight;
          ACanvas.Font.Color  := clActiveCaption;
    end
    else begin
          ACanvas.Brush.Color := Self.Color;
          ACanvas.Font.Color  := clWindowText;
    end;

end;

procedure TMyListView.DrawThumb(ACanvas: TCanvas;State: TCustomDrawState;
                Item: TListItem; RThumb: TRect);
var
  X, Y: integer;
  bmpThumb: TBitmap;
begin
    bmpThumb := TBitmap.Create;
    try
      FOnItemGetThumb(Self, Item, bmpThumb);

      X := RThumb.left + (RThumb.right - RThumb.left - bmpThumb.Width) div 2;
      Y := RThumb.top + (RThumb.bottom - RThumb.top -  bmpThumb.Height) div 2;
      ACanvas.Draw(X, Y, bmpThumb);

    finally
      bmpThumb.Free;
    end;

end;



//=========================================================================

procedure TForm1.FormActivate(Sender: TObject);
begin
   if FcreateNow then begin
     FCreateNow := false;
     FThumbLV.Items.BeginUpdate;
     try
       FThumbLV.Items.Clear;
       FThumbLV.Clear;
       FThumbLV.Items.Count := 10000;
     finally
       FThumbLV.Items.EndUpdate;
     end;
   end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var i,j: integer;
    s: string;
    c:word;
begin
   FCreateNow := true;
   FItems   := TStringList.Create;
   for i := 0 to 9999  do
   begin
       s := '';
       for j := 0 to 7 do
       begin
          c := Random(Succ(90 - 65)) + 65;
          s := s + Chr(c);
       end;
       FItems.Add(s);
   end;

   FThumbLV := TMyListView.Create(Self);
   FThumbLV.Align := alClient;
   FThumbLV.OnDataHint :=  lvDataHint;
   FThumbLV.OnData     := lvData;
   FThumbLV.SmallImages:= ImageList1;
   FThumbLV.OnItemGetThumb := lvGetThumb;

   FThumbLV.DoubleBuffered := true;
   FThumbLV.IconOptions.Arrangement := iaTop;

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FThumbLV.Free;
  FItems.Free;
end;

procedure TForm1.lvData(Sender: TObject; Item: TListItem);
begin
   if (Item <> nil) and (Item.Index < FItems.Count) then begin
      Item.Caption := FItems[Item.Index];
      Item.ImageIndex := 0;
   end;


end;

procedure TForm1.lvDataHint(Sender: TObject; StartIndex, EndIndex: Integer);
var i: integer;
begin
  //

end;

procedure TForm1.lvGetThumb(Sender:TObject; Item: TListItem; var AThumb: TBitmap);
begin
  ImageListThumb.GetBitmap(0, AThumb);
end;


end.

[marcos]

Hi,

ich habe leider immer noch keine Lösung. Arbeitet keiner mehr mit XP :)?

Grüße
marcos

[nemahl]

Hi, I have the same problem. Can you, please, tell how you solved the problem?

[Mackhack]

I'm working with XP SP3 English and it is perfectly working and the pictures stay as long as the app is running.

Proven with the screenshot attached!

[invalid_operation]

Hab Dein Projekt gerade mit D7pe unter Vista kompiliert, weder unter Vista noch XP sind die Grafiken zu sehen

[Mithrandir]

Zitat von invalid_operation:

Hab Dein Projekt gerade mit D7pe unter Vista kompiliert, weder unter Vista noch XP sind die Grafiken zu sehen

Ich hab das Projekt mit TDE kompilliert, läuft unter Windows XP SP 3 wunderbar. Eventuell ein Fehler seitens bestimmter Delphiversionen?

[marcos]

Ich habe gerade erneut XP mit 3 Delphi Versionen getestet: D7, D2007, D2009.
Es läuft auf XP, wenn ich mit D2007 die Exe erzeuge.
Wie kann man D2009 überzeugen, dass er richtig macht?

Gruß
marcos