Change the desktop wallpaper through code (Views: 28)
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; |