uses 
  Registry, ComObj, ShlObj; 
 
type
  Art = (Zentriert, Gestreckt, Gekachelt); 
 
function ActiveDesktop: boolean; 
var
  h: THandle; 
begin 
  h := FindWindow('Progman', nil); 
  h := FindWindowEx(h, 0, 'SHELLDLL_DefView', nil); 
  h := FindWindowEx(h, 0, 'Internet Explorer_Server', nil); 
  result := h > 0; 
end; 
 
procedure NormalWallpaper(bmp: string; wie: Art); 
var 
  WPStyle, TileWP: string; 
  reg: TRegInifile; 
begin 
  reg := TRegInifile.Create('Control Panel\Desktop'); 
  case wie of 
    gekachelt: begin WPStyle := '0'; 
        TileWP := '1'; 
      end; 
    gestreckt: begin WPStyle := '2'; 
        TileWP := '0'; 
      end; 
  else begin WPStyle := '0'; 
      TileWP := '0'; 
    end; 
  end; 
  with reg do begin 
    writestring('', 'Wallpaper', bmp); 
    writestring('', 'TileWallpaper', TileWP); 
    writestring('', 'WallpaperStyle', WPStyle); 
    free; 
  end; 
  Systemparametersinfo(SPI_SETDESKWALLPAPER, 0, nil, spif_updateinifile); 
end; 
 
procedure ActiveWallpaper(JPG: PWideChar; wie: Art); 
const 
  CLSIDAD: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}'; 
var 
  da: Bool; 
  AD: IActiveDesktop; 
  TCO: _tagCOMPONENTSOPT; 
  Options: _tagWALLPAPEROPT; 
begin 
  da := fileexists(JPG); 
  AD := CreateComObject(CLSIDAD) as IActiveDesktop; 
  with TCO do begin 
    dwSize := SizeOf(_tagCOMPONENTSOPT); 
    fEnableComponents := da; 
    fActiveDesktop := da; 
  end; 
  AD.SetDesktopItemOptions(TCO, 0); 
  with Options do begin 
    dwSize := SizeOf(_tagWALLPAPEROPT); 
    case wie of 
      gekachelt: dwStyle := WPSTYLE_TILE; 
      gestreckt: dwStyle := WPSTYLE_STRETCH; 
    else dwStyle := WPSTYLE_CENTER; 
    end; 
  end; 
  AD.SetWallpaper(JPG, 0); 
  AD.SetWallpaperOptions(Options, 0); 
  AD.ApplyChanges(AD_APPLY_ALL); 
end; 
 
procedure DeleteWallpaper; 
begin 
  if ActiveDesktop then 
    ActiveWallpaper('', zentriert) else 
    NormalWallpaper('', zentriert); 
end; 
 
procedure Wallpaper(bild: string; wie: Art); 
begin 
  if lowercase(extractfileext(bild)) <> '.bmp' then 
    ActiveWallpaper(StringToOLEStr(bild), wie) 
  else begin 
    DeleteWallpaper; 
    NormalWallpaper(bild, wie); 
  end; 
end; 
 
 
// --- Beispielaufrufe --- 
 
// ActiveDesktop-Hintergrundbild setzen 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  Wallpaper('c:\windows\web\wallpaper\background.jpg', gestreckt); 
end; 
 
// Normal-Hintergrundbild setzen 
procedure TForm1.Button7Click(Sender: TObject); 
begin 
  Wallpaper('c:\windows\angler.bmp', gekachelt); 
end; 
 
//  Hintergrundbild löschen 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  DeleteWallpaper; 
end;