Change the desktop wallpaper through code

Problem/Question/Abstract:

Does anyone have any idea how to change the wallpaper background in Windows. Browsers can do it, but I have no idea how to do this in Delphi. I need to write an app which changes the background wallpaper on demand.

Answer:

Solve 1:

procedure TfrmWallpaperChanger.ChangeWallPaper(Bitmap: string);
var
  pBitmap: pchar;
begin
  bitmap := bitmap + #0;
  pBitmap := @bitmap[1];
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, pBitmap, SPIF_UPDATEINIFILE);
end;


Solve 2:

procedure TForm1.Button1Click(Sender: TObject);
var
  St: array[0..100] of Char;
begin
  St := 'C:\Windows\MyWallPaper.bmp';
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, @St, SPIF_SENDCHANGE);
end;


Solve 3:

You can easily change the wallpaper for a Windows 95/ NT system from a Delphi application. Here's the code:

procedure ChangeIt;
var
  Reg: TRegIniFile;
begin
  Reg := TRegIniFile.Create('Control Panel');
  Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\forest.bmp');
  Reg.WriteString('desktop', 'TileWallpaper', '1');
  Reg.Free;
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end;

That's it! When you execute this procedure, you'll see the wallpaper change to the FOREST.BMP image. (This assumes that you're not using this image already.)


Solve 4:

The code below supports setting the exact position of the wallpaper and the ability to resize the wallpaper to fit the screen

uses
  Registry, WinProcs, SysUtils;

const
  {WallPaperStyles}
  WPS_Tile = 0;
  WPS_Center = 1;
  WPS_SizeToFit = 2;
  WPS_XY = 3;

  {sWallpaperBMPPath: Path to a BMP file
  nStyle: Any of the above WallPaperStyles
  nX, nY: If the nStyle is set to WPS_XY, nX and nY can be used to set the exact
               position of the wall paper}

procedure SetWallpaperExt(sWallpaperBMPPath: string; nStyle, nX, nY: integer);
var
  reg: TRegIniFile;
  s1: string;
  X, Y: integer;
begin
  {Change registry:

  HKEY_CURRENT_USER\
  Control Panel\Desktop
     TileWallpaper (REG_SZ)
     Wallpaper (REG_SZ)
     WallpaperStyle (REG_SZ)
     WallpaperOriginX (REG_SZ)
     WallpaperOriginY (REG_SZ)
  }
  reg := TRegIniFile.Create('Control Panel\Desktop');
  with reg do
  begin
    s1 := '0';
    X := 0;
    Y := 0;
    case nStyle of
      WPS_Tile: s1 := '1';
      WPS_Center: nStyle := WPS_Tile;
      WPS_XY:
        begin
          nStyle := WPS_Tile;
          X := nX;
          Y := nY;
        end;
    end;
    WriteString('', 'Wallpaper', sWallpaperBMPPath);
    WriteString('', 'TileWallpaper', s1);
    WriteString('', 'WallpaperStyle', IntToStr(nStyle));
    WriteString('', 'WallpaperOriginX', IntToStr(X));
    WriteString('', 'WallpaperOriginY', IntToStr(Y));
  end;
  reg.Free;
  {Let everyone know that we changed a system parameter}
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end;

Here are two examples on how to call the above SetWallpaperExt() function.

Set wallpaper to winnt.bmp and stretch it to fit the screen

SetWallpaperExt('c:\winnt\winnt.bmp', WPS_SizeToFit, 0, 0);

Set the wallpaper origin to (10, 200)

SetWallpaperExt('c:\winnt\winnt.bmp', WPS_XY, 10, 200);


Solve 5:

{ ... }
type
  TThemeWallpaperItem = record
    Filename: TFilename;
    Pattern: TFilename;
    Tile: Boolean;
    Style: TWallpaperStyle;
    ScreensaverActive: Boolean;
  end;

  TWallpaperValues = (wvWallpaper, wvPattern, wvTileWallpaper,
    wvWallpaperStyle, wvScreensaverActive);

const
  ThemeWallpaperSectionName = 'Control Panel\Desktop';
  ThemeWallpaperValueNames: array[TWallpaperValues] of string = ('Wallpaper',
    'Pattern', 'TileWallpaper', 'WallPaperStyle', 'ScreensaveActive');

procedure TThemeFile.WriteWallpaperToWindows;
var
  RegInifile: TRegIniFile;
const
  DefaultSectionName = 'Control Panel\Desktop';
begin
  RegInifile := TRegIniFile.Create;
  try
    RegIniFile.RootKey := HKEY_CURRENT_USER;
    {TWallpaperValues = (wvWallpaper, wvPattern, wvTileWallpaper, wvWallpaperStyle,
                                             wvScreensaverActive);}
    RegIniFile.WriteString(DefaultSectionName, ThemeWallpaperValueNames[wvWallpaper],
      FWallpaper.Filename);
    RegIniFile.WriteString(DefaultSectionName, ThemeWallpaperValueNames[wvPattern],
      FWallpaper.Pattern);
    RegIniFile.WriteBool(DefaultSectionName,
      ThemeWallpaperValueNames[wvTileWallpaper],
      FWallpaper.Tile);
    RegIniFile.WriteInteger(DefaultSectionName,
      ThemeWallpaperValueNames[wvWallPaperStyle],
      Integer(FWallpaper.Style))
  finally
    RegInifile.Free;
  end;
  SystemParametersInfo(SPI_SETDESKWALLPAPER, SPI_SETDESKWALLPAPER,
    PChar(FWallpaper.Filename), SPIF_SENDCHANGE or
    SPIF_UPDATEINIFILE);
  SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, Ord(FWallPaper.ScreensaverActive),
    nil, SPIF_SENDCHANGE or SPIF_UPDATEINIFILE);
  RefreshDesktop;
end;


Solve 6:

{ ... }
uses
  Registry, JPEG;

type
  TWallPaperStyle = (wpsCenter, wpsStretch, wpsTile);

const
  WALLPAPERSTYLESTRS: array[TWallPaperStyle] of string = ('Center', 'Stretch',
    'Tile');

function StrToWallPaperStyle(const s: string): TWallPaperStyle;
var
  wps: TWallPaperStyle;
begin
  result := wpsStretch;
  for wps := wpsCenter to wpsTile do
    if AnsiCompareText(s, WALLPAPERSTYLESTRS[wps]) = 0 then
    begin
      result := wps;
      exit;
    end;
end;

function RegGetWallPaperStyle: TWallPaperStyle;
var
  Reg: TRegistry;
  Center,
    Tile: boolean;
  s: string;
begin
  result := wpsStretch;
  Center := false;
  Tile := false;
  Reg := TRegistry.Create;
  try
    if Reg.OpenKey('Control Panel\Desktop', false) then
    begin
      if Reg.ValueExists('TileWallpaper') then
      begin
        s := Reg.ReadString('TileWallpaper');
        Tile := (s = '1');
      end;
      if Reg.ValueExists('WallpaperStyle') then
      begin
        s := Reg.ReadString('WallpaperStyle');
        Center := (s = '0');
      end;
      if Tile then
        result := wpsTile
      else if Center then
        result := wpsCenter;
    end;
  finally
    Reg.Free;
  end;
end;

procedure RegSetWallPaperStyle(wps: TWallPaperStyle);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    if Reg.OpenKey('Control Panel\Desktop', true) then
    begin
      case wps of
        wpsCenter:
          begin
            Reg.WriteString('TileWallpaper', '0');
            Reg.WriteString('WallpaperStyle', '0');
          end;
        wpsStretch:
          begin
            Reg.WriteString('TileWallpaper', '0');
            Reg.WriteString('WallpaperStyle', '2');
          end;
        wpsTile:
          begin
            Reg.WriteString('TileWallpaper', '1');
            {Reg.WriteString('WallpaperStyle', '0');}
          end;
      end;
    end;
  finally
    Reg.Free;
  end;
end;

procedure ChangeWallpaper(lpNewPaper: string; wps: TWallPaperStyle);
var
  Reg: TRegistry;
const
  SFolderKey = '\Control Panel\Desktop';
begin
  if not FileExists(lpNewPaper) or (CompareText('.bmp', ExtractFileExt(lpNewPaper)) <>
    0) then
    exit;
  Reg := TRegistry.Create;
  try
    if Reg.OpenKey(SFolderKey, false) then
    begin
      Reg.WriteString('Wallpaper', lpNewPaper);
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
  RegSetWallPaperStyle(wps);
  SystemParametersInfo(20, 0, PChar(lpNewPaper), $2);
end;

procedure SetWallpaper(const AFilename, NewFilename: string; wps:
  TWallPaperStyle);
var
  IsBitmapFile: boolean;
  bmp: TBitmap;
  pic: TPicture;
begin
  if FileExists(AFilename) then
  begin
    IsBitmapFile := AnsiCompareText('.bmp', ExtractFileExt(AFilename) = 0;
      if not IsBitmapFile then
      begin
        if (NewFilename = '') or (AnsiCompareText('.bmp', ExtractFileExt(NewFilename)
          <> 0) then
          raise Exception.Create('Wallpaper must be a bitmap file (*.bmp)');
          bmp := TBitmap.Create;
          try
            pic := TPicture.Create;
            try
              pic.LoadFromFile(AFilename);
              bmp.Assign(pic.Graphic);
            finally
              pic.Free;
            end;
            bmp.PixelFormat := pf24bit;
            bmp.SaveToFile(NewFilename);
            ChangeWallpaper(NewFilename, wps);
          finally
            bmp.Free;
          end;
      end
      else
        ChangeWallpaper(AFilename, wps);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  wps: TWallPaperStyle;
begin
  WallpaperCmbx.Clear; {TComboBox, style = csDropDownList, Sorted = false}
  for wps := wpsCenter to wpsTile do
    WallpaperCmbx.Items.Add(WALLPAPERSTYLESTRS[wps]);
  wps := RegGetWallPaperStyle;
  WallpaperCmbx.ItemIndex := ord(wps);
end;

procedure TForm1Button1Click(Sender: TObject);
var
  F, NewFName: string;
  wps: TWallPaperStyle;
begin
  with TOpenPictureDialog.Create(Self) do
  try
    if Execute then
    begin
      F := Filename;
      if AnsiCompareText('.bmp', ExtractFileExt(F)) <> 0 then
        NewFName := ChangeFileExt(F, '.bmp')
      else
        NewFName := '';
      wps := TWallPaperStyle(WallPaperCmbx.ItemIndex);
      SetWallpaper(F, NewFName, wps);
  finally
    Free;
  end;
end;