Author: Tomas Rutkauskas
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:
1
2 procedure TfrmWallpaperChanger.ChangeWallPaper(Bitmap: string);
3 var
4 pBitmap: pchar;
5 begin
6 bitmap := bitmap + #0;
7 pBitmap := @bitmap[1];
8 SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, pBitmap, SPIF_UPDATEINIFILE);
9 end;
Solve 2:
10 procedure TForm1.Button1Click(Sender: TObject);
11 var
12 St: array[0..100] of Char;
13 begin
14 St := 'C:\Windows\MyWallPaper.bmp';
15 SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, @St, SPIF_SENDCHANGE);
16 end;
Solve 3:
You can easily change the wallpaper for a Windows 95/ NT system from a Delphi
application. Here's the code:
17 procedure ChangeIt;
18 var
19 Reg: TRegIniFile;
20 begin
21 Reg := TRegIniFile.Create('Control Panel');
22 Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\forest.bmp');
23 Reg.WriteString('desktop', 'TileWallpaper', '1');
24 Reg.Free;
25 SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
26 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
27 uses
28 Registry, WinProcs, SysUtils;
29
30 const
31 {WallPaperStyles}
32 WPS_Tile = 0;
33 WPS_Center = 1;
34 WPS_SizeToFit = 2;
35 WPS_XY = 3;
36
37 {sWallpaperBMPPath: Path to a BMP file
38 nStyle: Any of the above WallPaperStyles
39 nX, nY: If the nStyle is set to WPS_XY, nX and nY can be used to set the exact
40 position of the wall paper}
41
42 procedure SetWallpaperExt(sWallpaperBMPPath: string; nStyle, nX, nY: integer);
43 var
44 reg: TRegIniFile;
45 s1: string;
46 X, Y: integer;
47 begin
48 {Change registry:
49
50 HKEY_CURRENT_USER\
51 Control Panel\Desktop
52 TileWallpaper (REG_SZ)
53 Wallpaper (REG_SZ)
54 WallpaperStyle (REG_SZ)
55 WallpaperOriginX (REG_SZ)
56 WallpaperOriginY (REG_SZ)
57 }
58 reg := TRegIniFile.Create('Control Panel\Desktop');
59 with reg do
60 begin
61 s1 := '0';
62 X := 0;
63 Y := 0;
64 case nStyle of
65 WPS_Tile: s1 := '1';
66 WPS_Center: nStyle := WPS_Tile;
67 WPS_XY:
68 begin
69 nStyle := WPS_Tile;
70 X := nX;
71 Y := nY;
72 end;
73 end;
74 WriteString('', 'Wallpaper', sWallpaperBMPPath);
75 WriteString('', 'TileWallpaper', s1);
76 WriteString('', 'WallpaperStyle', IntToStr(nStyle));
77 WriteString('', 'WallpaperOriginX', IntToStr(X));
78 WriteString('', 'WallpaperOriginY', IntToStr(Y));
79 end;
80 reg.Free;
81 {Let everyone know that we changed a system parameter}
82 SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
83 end;
84
85 //Here are two examples on how to call the above SetWallpaperExt() //function.
86
87 set wallpaper to winnt.bmp and stretch it to fit the screen
88
89 SetWallpaperExt('c:\winnt\winnt.bmp', WPS_SizeToFit, 0, 0);
90
91 set the wallpaper origin to (10, 200)
92
93 SetWallpaperExt('c:\winnt\winnt.bmp', WPS_XY, 10, 200);
Solve 5:
94 { ... }
95 type
96 TThemeWallpaperItem = record
97 Filename: TFilename;
98 Pattern: TFilename;
99 Tile: Boolean;
100 Style: TWallpaperStyle;
101 ScreensaverActive: Boolean;
102 end;
103
104 TWallpaperValues = (wvWallpaper, wvPattern, wvTileWallpaper,
105 wvWallpaperStyle, wvScreensaverActive);
106
107 const
108 ThemeWallpaperSectionName = 'Control Panel\Desktop';
109 ThemeWallpaperValueNames: array[TWallpaperValues] of string = ('Wallpaper',
110 'Pattern', 'TileWallpaper', 'WallPaperStyle', 'ScreensaveActive');
111
112 procedure TThemeFile.WriteWallpaperToWindows;
113 var
114 RegInifile: TRegIniFile;
115 const
116 DefaultSectionName = 'Control Panel\Desktop';
117 begin
118 RegInifile := TRegIniFile.Create;
119 try
120 RegIniFile.RootKey := HKEY_CURRENT_USER;
121 {TWallpaperValues = (wvWallpaper, wvPattern, wvTileWallpaper, wvWallpaperStyle,
122 wvScreensaverActive);}
123 RegIniFile.WriteString(DefaultSectionName,
124 ThemeWallpaperValueNames[wvWallpaper],
125 FWallpaper.Filename);
126 RegIniFile.WriteString(DefaultSectionName, ThemeWallpaperValueNames[wvPattern],
127 FWallpaper.Pattern);
128 RegIniFile.WriteBool(DefaultSectionName,
129 ThemeWallpaperValueNames[wvTileWallpaper],
130 FWallpaper.Tile);
131 RegIniFile.WriteInteger(DefaultSectionName,
132 ThemeWallpaperValueNames[wvWallPaperStyle],
133 Integer(FWallpaper.Style))
134 finally
135 RegInifile.Free;
136 end;
137 SystemParametersInfo(SPI_SETDESKWALLPAPER, SPI_SETDESKWALLPAPER,
138 PChar(FWallpaper.Filename), SPIF_SENDCHANGE or
139 SPIF_UPDATEINIFILE);
140 SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, Ord(FWallPaper.ScreensaverActive),
141 nil, SPIF_SENDCHANGE or SPIF_UPDATEINIFILE);
142 RefreshDesktop;
143 end;
144
145
146 Solve 6:
147
148 { ... }
149 uses
150 Registry, JPEG;
151
152 type
153 TWallPaperStyle = (wpsCenter, wpsStretch, wpsTile);
154
155 const
156 WALLPAPERSTYLESTRS: array[TWallPaperStyle] of string = ('Center', 'Stretch',
157 'Tile');
158
159 function StrToWallPaperStyle(const s: string): TWallPaperStyle;
160 var
161 wps: TWallPaperStyle;
162 begin
163 result := wpsStretch;
164 for wps := wpsCenter to wpsTile do
165 if AnsiCompareText(s, WALLPAPERSTYLESTRS[wps]) = 0 then
166 begin
167 result := wps;
168 exit;
169 end;
170 end;
171
172 function RegGetWallPaperStyle: TWallPaperStyle;
173 var
174 Reg: TRegistry;
175 Center,
176 Tile: boolean;
177 s: string;
178 begin
179 result := wpsStretch;
180 Center := false;
181 Tile := false;
182 Reg := TRegistry.Create;
183 try
184 if Reg.OpenKey('Control Panel\Desktop', false) then
185 begin
186 if Reg.ValueExists('TileWallpaper') then
187 begin
188 s := Reg.ReadString('TileWallpaper');
189 Tile := (s = '1');
190 end;
191 if Reg.ValueExists('WallpaperStyle') then
192 begin
193 s := Reg.ReadString('WallpaperStyle');
194 Center := (s = '0');
195 end;
196 if Tile then
197 result := wpsTile
198 else if Center then
199 result := wpsCenter;
200 end;
201 finally
202 Reg.Free;
203 end;
204 end;
205
206 procedure RegSetWallPaperStyle(wps: TWallPaperStyle);
207 var
208 Reg: TRegistry;
209 begin
210 Reg := TRegistry.Create;
211 try
212 if Reg.OpenKey('Control Panel\Desktop', true) then
213 begin
214 case wps of
215 wpsCenter:
216 begin
217 Reg.WriteString('TileWallpaper', '0');
218 Reg.WriteString('WallpaperStyle', '0');
219 end;
220 wpsStretch:
221 begin
222 Reg.WriteString('TileWallpaper', '0');
223 Reg.WriteString('WallpaperStyle', '2');
224 end;
225 wpsTile:
226 begin
227 Reg.WriteString('TileWallpaper', '1');
228 {Reg.WriteString('WallpaperStyle', '0');}
229 end;
230 end;
231 end;
232 finally
233 Reg.Free;
234 end;
235 end;
236
237 procedure ChangeWallpaper(lpNewPaper: string; wps: TWallPaperStyle);
238 var
239 Reg: TRegistry;
240 const
241 SFolderKey = '\Control Panel\Desktop';
242 begin
243 if not FileExists(lpNewPaper) or (CompareText('.bmp', ExtractFileExt(lpNewPaper))
244 <>
245 0) then
246 exit;
247 Reg := TRegistry.Create;
248 try
249 if Reg.OpenKey(SFolderKey, false) then
250 begin
251 Reg.WriteString('Wallpaper', lpNewPaper);
252 Reg.CloseKey;
253 end;
254 finally
255 Reg.Free;
256 end;
257 RegSetWallPaperStyle(wps);
258 SystemParametersInfo(20, 0, PChar(lpNewPaper), $2);
259 end;
260
261 procedure SetWallpaper(const AFilename, NewFilename: string; wps:
262 TWallPaperStyle);
263 var
264 IsBitmapFile: boolean;
265 bmp: TBitmap;
266 pic: TPicture;
267 begin
268 if FileExists(AFilename) then
269 begin
270 IsBitmapFile := AnsiCompareText('.bmp', ExtractFileExt(AFilename) = 0;
271 if not IsBitmapFile then
272 begin
273 if (NewFilename = '') or (AnsiCompareText('.bmp',
274 ExtractFileExt(NewFilename)
275 <> 0) then
276 raise Exception.Create('Wallpaper must be a bitmap file (*.bmp)');
277 bmp := TBitmap.Create;
278 try
279 pic := TPicture.Create;
280 try
281 pic.LoadFromFile(AFilename);
282 bmp.Assign(pic.Graphic);
283 finally
284 pic.Free;
285 end;
286 bmp.PixelFormat := pf24bit;
287 bmp.SaveToFile(NewFilename);
288 ChangeWallpaper(NewFilename, wps);
289 finally
290 bmp.Free;
291 end;
292 end
293 else
294 ChangeWallpaper(AFilename, wps);
295 end;
296 end;
297
298 procedure TForm1.FormCreate(Sender: TObject);
299 var
300 wps: TWallPaperStyle;
301 begin
302 WallpaperCmbx.Clear; {TComboBox, style = csDropDownList, Sorted = false}
303 for wps := wpsCenter to wpsTile do
304 WallpaperCmbx.Items.Add(WALLPAPERSTYLESTRS[wps]);
305 wps := RegGetWallPaperStyle;
306 WallpaperCmbx.ItemIndex := ord(wps);
307 end;
308
309 procedure TForm1Button1Click(Sender: TObject);
310 var
311 F, NewFName: string;
312 wps: TWallPaperStyle;
313 begin
314 with TOpenPictureDialog.Create(Self) do
315 try
316 if Execute then
317 begin
318 F := Filename;
319 if AnsiCompareText('.bmp', ExtractFileExt(F)) <> 0 then
320 NewFName := ChangeFileExt(F, '.bmp')
321 else
322 NewFName := '';
323 wps := TWallPaperStyle(WallPaperCmbx.ItemIndex);
324 SetWallpaper(F, NewFName, wps);
325 finally
326 Free;
327 end;
328 end;
|
