1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:

uses ShlApi;

function TfrmMain.GetDesktopBackground: String;
var
  DesktopObj: IActiveDesktop;
  Wallpaper: PWideChar;
begin
  Result := '';
  if SUCCEEDED(CoCreateInstance(CLSID_ActiveDesktop, nil, CLSCTX_INPROC_SERVER,
    IID_IActiveDesktop, DesktopObj)) then
  begin
    GetMem(Wallpaper, MAX_PATH*2);
    DesktopObj.GetWallpaper(Wallpaper, MAX_PATH*2, 0);
    Result := Wallpaper;
    if Result = '' then
      Result := 'none';
    FreeMem(Wallpaper, MAX_PATH*2);
  end;
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:

uses ShlApi;


function TfrmMain.SetDesktopBackground(uFile: String): Boolean;
var
  DesktopObj: IActiveDesktop;
  Wallpaper: PWideChar;
begin
  Result := False;
  if uFile = 'none' then
    uFile := '';
  if SUCCEEDED(CoCreateInstance(CLSID_ActiveDesktop, nil, CLSCTX_INPROC_SERVER,
    IID_IActiveDesktop, DesktopObj)) then
  begin
    GetMem(Wallpaper, MAX_PATH*2);
    StringToWideChar(uFile, Wallpaper, MAX_PATH*2);
    Result := DesktopObj.SetWallpaper(Wallpaper, 0) = S_OK;
    if Result then
      DesktopObj.ApplyChanges(AD_APPLY_ALL);
    FreeMem(Wallpaper, MAX_PATH*2);
//    Result := (Self.GetDesktopBackground = uFile)
//      or (Self.RegAccess.ReadString(
//        HKCU, 'Control Panel\Desktop', 'ConvertedWallpaper', '') = uFile);
//Diese Zeilen machen bei mir das Ergebnis erst zuverlässig, erfordern
//aber weiteren Code. Was passiert sollte aber klar sein...
  end;
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:

var
  frmMain: TfrmMain;
  Self.fLastDesktopBackground: String = '';

procedure TfrmMain.actFileSendToDesktopBackgroundExecute(Sender: TObject);
begin
  if (Self.MDIChildCount = 0)
    or (TfrmChild(Self.ActiveMDIChild).Filename = '') then
    Exit;
  Self.fLastDesktopBackground := Self.GetDesktopBackground;
  if not Self.SetDesktopBackground(TfrmChild(Self.ActiveMDIChild).Filename) then
    Application.MessageBox(PChar('Konnte Datei "'
      + TfrmChild(Self.ActiveMDIChild).Filename + '"' + #13
      + 'nicht als Desktop-Hintergrund setzen!'
      + IfThen(ExtractFileExt(TfrmChild(Self.ActiveMDIChild).Filename) = '.gif',
        #13 + #13 + 'Handelt es sich vielleicht um eine GIF-Animation?' + #13
        + 'Manchmal scheinen diese nicht zu funktionieren!')), 'Scriba: Fehler',
      mb_IconStop + mb_Ok);
end;

procedure TfrmMain.actUndoSetDesktopBackgroundExecute(Sender: TObject);
begin
  if Self.fLastDesktopBackground = '' then
    Exit;
  if Self.SetDesktopBackground(Self.fLastDesktopBackground) then
    Self.fLastDesktopBackground := ''
  else
    Application.MessageBox(PChar('Konnte Datei "'
      + Self.fLastDesktopBackground + '"' + #13
      + 'nicht als Desktop-Hintergrund setzen!'
      + IfThen(ExtractFileExt(Self.fLastDesktopBackground) = '.gif',
        #13 + #13 + 'Handelt es sich vielleicht um eine GIF-Animation?' + #13
        + 'Manchmal scheinen diese nicht zu funktionieren!')), 'Scriba: Fehler',
      mb_IconStop + mb_Ok);
end;