Active Desktop打开的情况下在程序中更换墙纸

http://lovejingtao2000.home.chinaren.com/wallset.htm
{如何在Win98/Win2000Active Desktop打开的情况下在程序中更换墙纸 ,本程序用了两个Button和三个Label }
unit Unit1;
interface
//By Lovejingtao.http://Lovejingtao.126.com
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,, ExtCtrls, ExtDlgs
ComObj,//用来创建COM对象
ShlObj;//用来检测桌面
type
TForm1 = class(TForm)
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
const
CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
ActiveDesktop: IActiveDesktop;
CurrentWallpaper: string;
CurrentPattern: string;
WallpaperOptions: TWallpaperOpt;
tmpBuffer: PWideChar;
begin
///// 创建 COM 对象////////////////////////////////////////////////////////
ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
/////////////////////检查图像名称/////////////////////////////////////////
tmpBuffer := AllocMem(MAX_PATH*2);
try
ActiveDesktop.GetWallpaper(tmpBuffer, MAX_PATH*2, 0);
CurrentWallpaper := tmpBuffer;
finally
FreeMem(tmpBuffer);
end;
if CurrentWallpaper <> '' then
Label1.Caption := '当前桌面图像: ' + CurrentWallpaper
else
Label1.Caption := '没有设置桌面图片';
///////////检查图像显示方式//////////////////////////////////
WallpaperOptions.dwSize := SizeOf(WallpaperOptions);
ActiveDesktop.GetWallpaperOptions(WallpaperOptions, 0);
case WallpaperOptions.dwStyle of
WPSTYLE_CENTER: Label2.Caption := '图像显示方式:居中';
WPSTYLE_TILE: Label2.Caption := '图像显示方式:平铺';
WPSTYLE_STRETCH: Label2.Caption := '图像显示方式:拉伸';
WPSTYLE_MAX: Label2.Caption := '图像显示方式:最大化';
end;
///////////////检查图案设置//////////////////////////////////
tmpBuffer := AllocMem(256);
try
ActiveDesktop.GetPattern(tmpBuffer, 256, 0);
CurrentPattern := tmpBuffer;
finally
FreeMem(tmpBuffer);
end;
if CurrentPattern <> '' then
Label3.Caption := CurrentPattern
else
Label3.Caption := '图案设置:没有设置图案';
////////////////////////////////////////////////////////////
end;
　
procedure TForm1.Button2Click(Sender: TObject);
var
ActiveDesktop: IActiveDesktop;
begin
if Not FileExists('C:.bmp') then
begin
Application.MessageBox('C:.bmp不存在!','请检查文件',MB_ICONINFORMATION+MB_OK);
Exit;
end;
ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
ActiveDesktop.SetWallpaper('C:.bmp', 0);
ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
end;
end.