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;
wallpaperwideChar;
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.
但是不知道怎样让这个图片居中或拉伸显示。
其实我是想模拟桌面,代码如下:
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;
wallpaperwideChar;
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.