如何像设置Windows桌面墙纸那样可以动态设置系统主界面的墙纸？应该怎么做？

Question

是不是要调用win API函数啊？最好能给点具体的代码

Answer 1

procedure TmainForm.FormCreate(Sender: TObject);
var
  pic:Trect;
  map:Tbitmap;
  intX,l1,l2:integer;
begin
    //设置背景
    image1.Align:=alClient;
    map:=Tbitmap.create;
    map.loadfromfile(G_path+'\1067.bmp');
    l1:=Width div map.Width;
    l2:=Height div map.Height + 5;
    For intX:= 0 To  l1 do
        begin
           pic.topleft.x:=intX*map.Width;
           pic.bottomright.x:=pic.topleft.x+map.Width;
           For intY:= 0 To l2 do
                begin
                    pic.topleft.y:=intY*map.Height;
                    pic.bottomright.y:=pic.topleft.y+map.Height;
                 image1.canvas.stretchdraw(pic,map);
                end;
        end;
end;

Answer 2

更换墙纸    
  
// 1.Way:usesRegistry;procedure SetWallpaper(sWallPaperBMPPath: string; bTile: Boolean);varreg: TRegIniFile;beginreg := TRegIniFile.Create('Control Panel');trywith reg dobeginWriteString('', 'Wallpaper', sWallPaperBMPPath);WriteString('', 'TileWallpaper', IntToStr(Ord(bTile)));end;finallyreg.Free;end;SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);end;// 2. Way:procedure TForm1.Button1Click(Sender: TObject);varsWallPaperBMPPath: string;beginsWallPaperBMPPath := 'C:[WinDIR].bmp';if not SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Pointer(sWallPaperBMPPath),SPIF_SENDWININICHANGE) thenShowMessage('Succesful.')elseShowMessage('Failed!');end;　// 3. Set the wallpaper for the Active Desktop.{You may have noticed that using SystemParametersInfo to change the wallpaperwhen ActiveDesktop is turned on doesn't work. The reason is because you needto use the IActiveDesktop COM interface. Using SystemParametersInfo still works,but it doesn't update the wallpaper.Requires Internet Explorer 4.0 or later).}　　usesShlObj, ComObj;　function ChangeWallpaper(aFile: String): Boolean;constCLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';varhObj: IUnknown;ADesktop: IActiveDesktop;str: string;wstr: PWideChar;beginhObj := CreateComObject(CLSID_ActiveDesktop);ADesktop := hObj as IActiveDesktop;wstr := AllocMem(MAX_PATH);tryStringToWideChar(aFile, wstr, MAX_PATH);ADesktop.SetWallpaper(wstr, 0);ADesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);finallyFreeMem(wstr);end;end;**************************************活动桌面下更换墙纸：uses shlobj;获得墙纸procedure TForm1.Button1Click(Sender: TObject);varADeskTop:IActiveDesktop;wallpaper:PwideChar;beginADeskTop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;GetMem(wallpaper,128);ADeskTop.GetWallpaper(wallpaper,128,0);ShowMessage(string(wallpaper));FreeMem(wallpaper);end;设置墙纸procedure TForm1.Button1Click(Sender: TObject);varADeskTop:IActiveDesktop;wallpaper:PwideChar;beginADeskTop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;wallpaper:='d:2.bmp';ADeskTop.SetWallpaper(wallpaper,0);ADeskTop.ApplyChanges(AD_APPLY_ALL);end;
 
 

Answer 3

uses Registry,jpeg,graphics;procedure SetWallpaper(const FileName:String);
var Wallpaper:String;ext:string;
 //转换函数
 function ConvertToBitmap(const FileName:String):string;
 var jpg:TJPEGImage;bmp:TBitmap;
 begin
  jpg:=TJPEGImage.Create;
  bmp:=TBitmap.Create;
  Result:=ChangeFileExt(FileName,'.bmp');
  try
    jpg.LoadFromFile(FileName);
    bmp.Assign(jpg);
    bmp.SaveToFile(Result);
  finally
    bmp.Free;
    jpg.Free;
  end;
 end;
begin
  //判断是否是bmp或者jpg格式
  ext:=LowerCase(ExtractFileExt(FileName));
  if CompareText(ext,'.jpg') * CompareText(ext,'.bmp')<>0 then
    raise Exception.Create('不支持这种图片格式！');
  //jpg格式则转换成bmp格式
  if CompareText(ext,'.jpg')=0 then
    Wallpaper:=ConvertToBitmap(FileName)
  else
    Wallpaper:=FileName;
  //修改注册表
  with TRegistry.Create do
  begin
    Root:=HKEY_CURRENT_USER;
    OpenKey('Control Panel\Desktop');
    WriteString('Wallpaper',Wallpaper);
    CloseKey();
    Free;
  end;
  //通知Shell
  SystemParameterInfo(SPI_SETDESKWALLPAPER ,PChar(Wallpaper),0,SPIF_SENDCHANGE or SPIF_UPDATEINIFILE );
end;随手写的，在网吧没delphi测试，昨天还给自己写了一个随机更换壁纸的程序，现在还记得一些相关注册表键值，应该没有问题