TListView - Problem mit Miniaturansichten mit OwnerData

[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.