ListView中加了背景图后,怎样让这个图片拉伸显示?或者居中显示?(100分)

  • 主题发起人 主题发起人 wgqsoft
  • 开始时间 开始时间
W

wgqsoft

Unregistered / Unconfirmed
GUEST, unregistred user!
我已经实现了往Listview中加背景图,并让上面的图标透明。
但是不知道怎样让这个图片居中或拉伸显示。
其实我是想模拟桌面,代码如下:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ImgList, CommCtrl, ShellCtrls, ShellAPI, ShellConsts, ShlObj, ComObj, ExtCtrls;

type
TForm1 = class(TForm)
ListView1: TListView;
ShellListView1: TShellListView;
procedure FormCreate(Sender: TObject);
procedure ListView1CustomDraw(Sender: TCustomListView;
const ARect: TRect; var DefaultDraw: Boolean);
procedure ListView1CustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
private
FBkBmp: TBitmap;
FLargeImages: TImageList;
bWallPaper: Boolean;
WallStyle: DWORD;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
i: Integer;
Item: TListItem;
FileInfo: TSHFileInfo;
ADeskTop: IActiveDesktop;
wallpaper:PwideChar;
StrWallPaper: string;
WPO: TWallpaperOpt;
begin
ListView1.Color:=GetSysColor(COLOR_DESKTOP);
ListView1.Font.Color:=clWhite;
ListView1.Font.Size:=8;
ListView1.Font.Name:='Tahoma';
ListView1.ViewStyle:=vsIcon;

{ 返回桌面墙纸和墙纸的显示模式:居中、平铺、拉伸 }
ADeskTop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
GetMem(wallpaper,500);
ADeskTop.GetWallpaper(wallpaper,500,0);
WPO.dwSize:=SizeOf(WPO);
ADeskTop.GetWallpaperOptions(WPO, 0);
WallStyle:=WPO.dwStyle;
StrWallPaper:=string(Wallpaper);
FreeMem(wallpaper);

if Trim(StrWallPaper) <> '' then
begin
FBkBmp:=TBitmap.Create;
FBkBmp.LoadFromFile(StrWallPaper);
FBKBmp.Transparent:=True;
bWallPaper:=True;
end else bWallPaper:=False;

{ 得到桌面上项目的图标列表 }
ListView1.Clear;
FLargeImages:=TImageList.Create(Self);
FLargeImages.ShareImages:=True;
FLargeImages.Handle:=SHGetFileInfo(PChar(SRFDesktop),
0, FileInfo, SizeOf(FileInfo),
SHGFI_LARGEICON or SHGFI_SYSICONINDEX or SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES);
ListView1.LargeImages:=FLargeImages;

{ 利用放在窗体上的 ShellListView 来得到当前桌面的项目 }
for i:=0 to ShellListView1.Items.Count-1 do
begin
Item:=ListView1.Items.Add;
Item.Caption:=ShellListView1.Folders.DisplayName;
Item.SubItems.Add(ShellListView1.Folders.PathName);
Item.ImageIndex:=ShellListView1.Folders.ImageIndex(True);
end;
end;

procedure TForm1.ListView1CustomDraw(Sender: TCustomListView;
const ARect: TRect; var DefaultDraw: Boolean);
begin
if bWallPaper then
begin
{ 关键是这个地方 }
if WallStyle = WPSTYLE_TILE then
begin { 平铺模式 }
Sender.Brush.Bitmap:=FBKBmp;
Sender.Canvas.Brush.Bitmap:=FBKBmp;
Sender.Canvas.FillRect(ARect);
end else
if WallStyle = WPSTYLE_STRETCH then
begin { 拉伸模式 }
Sender.Canvas.StretchDraw(ARect,FBkBmp);
{ 用这个方法,显示出来很不正常,用什么办法替代呢? }
end else
if WallStyle = WPSTYLE_CENTER then
begin { 居中模式 }
{ 不知道怎么写? }
end;
end;
end;

procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
var
Images:TCustomImageList;
R: TRect;
iStyle: Integer;
begin
with Sender as TListView do
begin
Images:=LargeImages; { ListView.ViewStyle必须设为 vsIcon }
if Images <> nil then
begin
R:=Item.DisplayRect(drIcon);
if cdsSelected in State then iStyle:=ILD_SELECTED or ILD_TRANSPARENT
else iStyle:=ILD_TRANSPARENT;
ImageList_DrawEx(Images.Handle, Item.ImageIndex, Canvas.Handle,
R.Left+(R.Right-R.Left-Images.Width) div 2,
R.Top+(R.Bottom-R.Top-Images.Height) div 2,0, 0,
clNone, clNone, iStyle);
end;
R:=Item.DisplayRect(drLabel);
if cdsSelected in State then
begin
Canvas.Brush.Style := bsSolid;
SetTextColor(Canvas.Handle,clWhite);
SetBkColor(Canvas.Handle,clNavy);
SetBkMode(Canvas.Handle,Windows.OPAQUE);
DrawText(Canvas.Handle, PAnsiChar(Item.Caption),
Length(Item.Caption), R, DT_CENTER or DT_WORDBREAK);
end else
begin
Canvas.Brush.Style:=bsClear;
SetBkMode(Canvas.Handle,Windows.TRANSPARENT);
Canvas.Font.Style:=[fsBold];
DrawText(Canvas.Handle, PAnsiChar(Item.Caption),
Length(Item.Caption), R, DT_CENTER or DT_WORDBREAK);
end;
DefaultDraw:=False;
end;
end;

end.
 
鄙人自费建了一个QQ群 ,号码:22037366 请大家申请加入,唯一的要求是不要谈论Delphi以外的东西,我们的目标是将Delphi进行到底
 
给你添加了拉伸和居中方法
procedure TForm1.ListView1CustomDraw(Sender: TCustomListView;
const ARect: TRect; var DefaultDraw: Boolean);
var
R1, R2: TRect;
begin
if bWallPaper then
begin
{ 关键是这个地方 }
if WallStyle = WPSTYLE_TILE then
begin { 平铺模式 }
Sender.Brush.Bitmap:=FBKBmp;
Sender.Canvas.Brush.Bitmap:=FBKBmp;
Sender.Canvas.FillRect(ARect);
end else
if WallStyle = WPSTYLE_STRETCH then
begin { 拉伸模式 }
//Sender.Canvas.StretchDraw(ARect,FBkBmp);
//经测试,你原来的方式也是可以的,只是刷新速度慢,用以下方法速度快了不少
StretchBlt(Sender.Canvas.Handle, ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top,
FBkBmp.Canvas.Handle, 0, 0, FBkBmp.Width, FBkBmp.Height, SRCCOPY);
end else
if WallStyle = WPSTYLE_CENTER then
begin { 居中模式 }
R1.Left := ARect.Left + (ARect.Right - ARect.Left - FBkBmp.Width) div 2;
R1.Top := ARect.Top + (ARect.Bottom - ARect.Top - FBkBmp.Height) div 2;
R1.Right := R1.Left + FBkBmp.Width;
R1.Bottom := R1.Top + FBkBmp.Height;
R2 := Rect(0, 0, FBkBmp.Width, FBkBmp.Height);
Sender.Canvas.CopyRect(R1, FBkBmp.Canvas, R2);
end;
end;
end;

//建议加以下代码及时刷新界面
procedure TForm1.FormResize(Sender: TObject);
begin
ListView1.Refresh;
end;

你是做一个伪装桌面的东东吧,呵呵,
 
写的不错
 
后退
顶部