如何用ListView实现缩略图?(200分)

不知大家用过ClipMate吗，它的图片和文字的缩略图是如何做的？请各位大虾指教！

用ListView会好和简单一些 ACDSEE就是ListView 好处可以在各种显示形式之间切换
变通的方法就太多了 比如DrawGrid

自己直接写把，从TPaintBox 继承出来，所有的位图都存储在内存里。只在Paint的时候动态贴出来。自己控制图片的大小和位置，绝对自由。难度应该不是太高，如果不是现在忙，干脆我给写一个算了。。哈哈哈[]

有个例子，不过没什么意义，Graphic_YUKI是私人函数，我去掉了。
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, ComCtrls, StdCtrls, ExtCtrls, ShellCtrls, ToolWin,jpeg; //Graphic_YUKI,enreg , GraphicEx ;
type
TMainForm = class(TForm)
ShellTreeView1: TShellTreeView;
Splitter1: TSplitter;
PaintBox: TPaintBox;
ScrollBox1: TScrollBox;
ToolBar1: TToolBar;
Button1: TButton;
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure PaintBoxPaint(Sender: TObject);
procedure ShellTreeView1Change(Sender: TObject; Node: TTreeNode);
procedure Button1Click(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
private
FThumbFrame,
FThumbOffset,
FTextHeight: Integer;
FFileList: TList;
FSelectedImage,
FThumbWidth,
FThumbHeight: Integer;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure CalculateSize;
procedure ClearFileList;
procedure RescaleImage(NewWidth, NewHeight: Integer; Source: TBitmap;
StretchMode: Integer);
procedure CalculateCounts(var XCount, YCount, HeightPerLine, ImageWidth:
Integer);
procedure PIC_Dir(FDirectory: string);
public
{ Public declarations }
end;

var
MainForm: TMainForm;
implementation

{$R *.DFM}
type
PFileEntry = ^TFileEntry;
TFileEntry = record
Name: string;
Bitmap: TBitmap;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
FThumbFrame := 2;
FThumbOffset := 15;
FTextHeight := 15;
FThumbWidth := 100;
FThumbHeight := 100;
FSelectedImage := -1;
FFileList := TList.Create;
end;

procedure TMainForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;

procedure TMainForm.CalculateCounts(var XCount, YCount, HeightPerLine,
ImageWidth: Integer);
begin
// How many images per line?
ImageWidth := FThumbWidth + 2 * (FThumbFrame + 1) + FThumbOffset;
XCount := Trunc((PaintBox.Width + FThumbOffset) / ImageWidth);
if XCount = 0 then
XCount := 1;
// How many (entire) images above the client area?
HeightPerLine := FThumbHeight + 2 * (FThumbFrame + 1) + FThumbOffset +
FTextHeight;
YCount := Trunc(ScrollBox1.VertScrollBar.Position / HeightPerLine);
end;

procedure TMainForm.ClearFileList;
var
I: Integer;
ImageData: PFileEntry;
begin
if FFileList = nil then
FFileList := TList.Create;
for I := 0 to FFileList.Count - 1 do
begin
ImageData := FFileList;
ImageData.Bitmap.Free;
Dispose(ImageData);
end;
FFileList.Clear;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
ClearFileList;
FFileList.Free;
end;

procedure TMainForm.RescaleImage(NewWidth, NewHeight: Integer; Source: TBitmap;
StretchMode: Integer);
var
Target: TBitmap;
F_Width, F_Height: Integer;
begin
if Source = nil then
exit;
Target := TBitmap.Create;
if (Source.Width > NewWidth) or (Source.Height > NewHeight) then
begin
if (Source.Width / Source.Height) > (NewWidth / NewHeight) then
begin
F_Width := NewWidth;
F_Height := Round(Source.Height * NewWidth / Source.Width);
end
else
begin
F_Height := NewHeight;
F_Width := Round(Source.Width * NewHeight / Source.Height);
end;
if StretchMode<4 then
begin
Target.PixelFormat := pf24Bit;
Target.Width := F_Width;
Target.Height := F_Height;
Target.Palette := Source.Palette;
SetStretchBltMode(Target.Canvas.Handle, StretchMode);
StretchBlt(Target.Canvas.Handle, 0, 0, F_Width, F_Height,
Source.Canvas.Handle, 0, 0, Source.Width, Source.Height, SRCCOPY);
//Target.Canvas.CopyRect(Rect(0, 0, NewWidth, NewHeight), Source.Canvas, Rect(0, 0, Source.Width, Source.Height));
end
// else Stretch(F_Width, F_Height, sfTriangle, 0, Source, Target);
end
else
Target.Assign(Source);
Source.Assign(Target);
Target.Free;
end;

function Compare(Item1, Item2: Pointer): Integer;
begin
Result := CompareText(PFileEntry(Item1).Name, PFileEntry(Item2).Name);
end;

procedure TMainForm.FormResize(Sender: TObject);
begin
CalculateSize;
Invalidate;
end;

procedure TMainForm.CalculateSize;
var
ImageWidth,
XCount,
HeightPerLine: Integer;
begin
// How many images per line?
ImageWidth := FThumbWidth + 2 * (FThumbFrame + 1) + FThumbOffset;
XCount := Trunc((PaintBox.Width + FThumbOffset) / ImageWidth);
if XCount = 0 then
XCount := 1;
// How many lines are this?
HeightPerLine := FThumbHeight + 2 * (FThumbFrame + 1) + FThumbOffset +
FTextHeight;
ScrollBox1.VertScrollBar.Range := HeightPerLine * (FFileList.Count div
XCount);
end;

procedure TMainForm.PIC_Dir(FDirectory: string);
var
Picture: TPicture;
SR: TSearchRec;
Entry: PFileEntry;
N: Integer;
bmp: TBitmap;
FD: string;
begin
ClearFileList;
ScrollBox1.VertScrollBar.Range := 0;
FD:=FDirectory;
if AnsiLastChar(FD)^ <> '/' then
FDirectory := FD + '/';
Picture := TPicture.Create;
bmp := TBitmap.Create;
try
if FindFirst(FDirectory + '*.*', faAnyFile, SR) = 0 then
begin
// iterate through the picked folder and collect all known image files
repeat
if SR.Attr <> faDirectory then
begin
// check whether this file is an image file we can show
if pos(ExtractFileExt(SR.Name), GraphicFileMask(TGraphic)) > 0 then
begin
New(Entry);
Entry.Name := SR.Name;
Entry.Bitmap := TBitmap.Create;
FFileList.Add(Entry);
Caption := IntToStr(FFileList.Count) + ' 图片';
end;
end;
until FindNext(SR) <> 0;
FindCLose(SR);
CalculateSize;
for N := 0 to FFileList.Count - 1 do
begin
Application.ProcessMessages;
if n > FFileList.Count - 1 then
break;
if FD<>ShellTreeView1.Path then
break;
Entry := FFileList[n];
Picture.LoadFromFile(FDirectory + Entry.Name);
bmp.Assign(Picture.Graphic);
RescaleImage(FThumbWidth, FThumbHeight, bmp, ComboBox1.ItemIndex+1); // HALFTONE COLORONCOLOR
Entry.Bitmap.Assign(bmp);
PaintBoxPaint(nil);
Caption := IntToStr(n + 1) + '/' + IntToStr(FFileList.Count) +
' 图片';
end
end;
FFileList.Sort(Compare);
finally
Caption := IntToStr(FFileList.Count) + ' 图片';
Picture.Free;
bmp.Free;
end;
end;

procedure TMainForm.PaintBoxPaint(Sender: TObject);
var
XPos,
YPos,
Index,
XCount,
YCount,
HeightPerLine,
ImageWidth,
EraseTop: Integer;
R, ImageR, TextR: TRect;
S: string;
ImageData: PFileEntry;
begin
with PaintBox.Canvas do
begin
// calculate and set initial values
Brush.Color := clBtnHighlight;
Pen.Width := FThumbFrame;
Pen.Color := clBtnHighlight;
CalculateCounts(XCount, YCount, HeightPerLine, ImageWidth);
// vertical draw offset is then:
YPos := 5 - VertScrollBar.Position + YCount * HeightPerLine;
// finally we need the image index to start with
Index := XCount * YCount;
// from where to start erasing unfilled parts
EraseTop := 0;
// now loop until the client area is filled
if Index < FFileList.Count then
repeat
// Application.ProcessMessages;
XPos := (Index mod XCount) * ImageWidth;
if Index >= -1 then
begin
// get current image
ImageData := FFileList[Index];
// determine needed display area
R := Rect(XPos, YPos, XPos + FThumbWidth + 2 * (FThumbFrame + 1),
YPos + FThumbHeight + 2 * (FThumbFrame + 1) + FTextHeight);
S := ExtractFileName(ImageData.Name);
TextR := R;
TextR.Top := TextR.Bottom - FTextHeight;
OffsetRect(TextR, 0, -(1 + FThumbFrame));
InflateRect(TextR, -(1 + FThumbFrame), 0);
// skip images not shown in the client area
if R.Bottom > 0 then
begin
// early out if client area is filled
if R.Top > PaintBox.Height then
Break;
// fill thumb frame area (frame only to avoid flicker)
if Index = FSelectedImage then
Pen.Color := clBlack
else
Pen.Color := clBtnHighlight;
with R do
Polyline([Point(Left + 2, Top + 2), Point(Right - 2, Top + 2),
Point(Right - 2, Bottom - 2), Point(Left + 2, Bottom - 2),
Point(Left + 2, Top + 1)]);
// draw image centered
ImageR := Rect(R.Left + 1 + FThumbFrame + (FThumbWidth -
ImageData.Bitmap.Width) div 2,
R.Top + 1 + FThumbFrame + (FThumbHeight - ImageData.Bitmap.Height)
div 2,
0, 0);
ImageR.Right := ImageR.Left + ImageData.Bitmap.Width;
ImageR.Bottom := ImageR.Top + ImageData.Bitmap.Height;
Draw(ImageR.Left, ImageR.Top, ImageData.Bitmap);
with ImageR do
ExcludeClipRect(Handle, Left, Top, Right, Bottom);
FillRect(R);
// a bevel around image and text
DrawEdge(Handle, R, BDR_SUNKENOUTER, BF_RECT);
// draw caption
DrawText(Handle, PChar(ImageData.Name), Length(ImageData.Name),
TextR, DT_END_ELLIPSIS or
DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
with R do
ExcludeClipRect(Handle, Left, Top, Right, Bottom);
end;
end
else
EraseTop := YPos;
Inc(Index);
// go to next line if this one is filled
if (Index mod XCount) = 0 then
Inc(YPos, HeightPerLine);
until (YPos >= PaintBox.Height) or (Index = FFileList.Count);
end;
// erase parts of the screen not covered by image(s)
FillRect(PaintBox.Canvas.Handle, Rect(0, EraseTop, PaintBox.Width,
PaintBox.Height), COLOR_BTNFACE + 1);
end;

procedure TMainForm.ShellTreeView1Change(Sender: TObject; Node: TTreeNode);
var
Start: cardinal;
begin
Start := GetTickCount;
PIC_Dir(ShellTreeView1.Path);
Caption := Caption + ' ' + IntToStr(GetTickCount - Start) + ' ms';
end;

procedure TMainForm.Button1Click(Sender: TObject);
begin
Application.MessageBox(pchar(GraphicFileMask(TGraphic)), '支持类型', MB_OK);
end;
procedure TMainForm.ComboBox1Change(Sender: TObject);
begin
ShellTreeView1Change(nil,nil)
end;

end.
-----------------
object MainForm: TMainForm
Left = 202
Top = 109
Width = 590
Height = 388
VertScrollBar.Tracking = True
Caption = 'Directory image browser demo program'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
Position = poDesktopCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object Splitter1: TSplitter
Left = 169
Top = 22
Height = 339
end
object ShellTreeView1: TShellTreeView
Left = 0
Top = 22
Width = 169
Height = 339
ObjectTypes = [otFolders]
Root = 'rfDesktop'
UseShellImages = True
Align = alLeft
AutoRefresh = False
Indent = 19
ParentColor = False
RightClickSelect = True
ShowRoot = False
TabOrder = 0
OnChange = ShellTreeView1Change
end
object ScrollBox1: TScrollBox
Left = 172
Top = 22
Width = 410
Height = 339
VertScrollBar.Tracking = True
Align = alClient
TabOrder = 1
object PaintBox: TPaintBox
Left = 0
Top = 0
Width = 406
Height = 335
Align = alClient
OnPaint = PaintBoxPaint
end
end
object ToolBar1: TToolBar
Left = 0
Top = 0
Width = 582
Height = 22
Caption = 'ToolBar1'
EdgeInner = esNone
EdgeOuter = esNone
Flat = True
TabOrder = 2
object Button1: TButton
Left = 0
Top = 0
Width = 75
Height = 22
Caption = '支持类型'
TabOrder = 0
OnClick = Button1Click
end
object ComboBox1: TComboBox
Left = 75
Top = 0
Width = 145
Height = 21
Style = csDropDownList
ItemHeight = 13
ItemIndex = 2
TabOrder = 1
Text = 'COLORONCOLOR = 3;'
OnChange = ComboBox1Change
Items.Strings = (
'BLACKONWHITE = 1;'
'WHITEONBLACK = 2;'
'COLORONCOLOR = 3;'
'HALFTONE = 4;'
'DoStretch = 5;')
end
end
end

留下邮箱，给你代码

yczjs@163.com
谢谢斯人

cxz@gsta.com

3x

上面例子是在PaintBox画的的没什么意义
不如参考
http://www.delphibbs.com/delphibbs/dispq.asp?lid=2154318
上的回答,里面发的控件TImageYuki可以当缩略图用，要跟上ACDSEE的速度，要看你解码图象函数能力了

suocy5@163.com

www.playicq.com上有模仿ACDSEE的一段

请楼主收邮件，已经发送！

我怎么还没收到你的邮件呢

哥哥的代码太棒了