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.