Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2010年07月07日] [更新 2014年05月11日]　Delphi サンプルプログラム集
SystemParametersInfo 関数サンプル
S02_デスクトップ関係
動作確認等 Windows 7 U64(SP1) + Delphi XE Pro
Windows 8.1 Pro64 + Delphi XE Pro
S02_SystemParametersInfo_Destop.zip　[7,009 KB]　2014年05月11日版 (EXE 同梱)



  • 2014年04月22日
  • IActiveDesktop とスライドショーのサンプルを追加



01_デスクトップの壁紙 ( 壁紙 )


デスクトップの背景に表示するビットマップの取得，設定するサンプルです．


表1
uiAction パラメータは SystemParametersInfo 関数の第 1 引数
uiParam は第 2 引数で，pvParam は第 3 引数

uiAction パラメータ uiParam と pvParam パラメータ
SPI_GETDESKWALLPAPER 取得
uiParam にはバッファのサイズを文字数単位で指定
pvParam はバッファへのポインタ
関数実行後，バッファに、フルパス名 (NULL 終端文字列) が戻ってくる．壁紙が指定されていない場合は空文字列
SPI_SETDESKWALLPAPER 設定
uiParam は 0
pvParam に壁紙のビットマップファイル名 (NULL 終端文字列)のポインタを指定
pvParam が空の文字列の場合，壁紙は非表示となる
pvParam に SETWALLPAPER_DEFAULT または nil を指定すると，既定の壁紙に戻る


図1
設計時画面
  • [壁紙変更] ボタンをクリックすると，ビットマップファイルの選択ダイアログを表示する
図2
壁紙変更前
図3
壁紙変更

リスト1
デスクトップの壁紙の取得と設定 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    OpenDialog1: TOpenDialog;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    OrignalWallPaper : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  プログラムを起動したら現在の壁紙のフルパスを取得しておく
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  Buff : array [0..MAX_PATH-1] of Char;
begin
  FillChar(Buff, MAX_PATH, #0);
  SystemParametersInfo(SPI_GETDESKWALLPAPER,
                       MAX_PATH,
                       @Buff,
                       0);
  OrignalWallPaper := Buff;
end;

//=============================================================================
//  壁紙変更
//  選択したビットマップが画面サイズで表示される
//  表示方法を変更したい場合はレジストリの操作が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AWallpaper : String;
begin
  OpenDialog1.Filter := 'ビットマップ|*.bmp';
  if OpenDialog1.InitialDir = '' then begin
    OpenDialog1.InitialDir := ExtractFileDir(Application.ExeName);
  end;
  if OpenDialog1.Execute = False then exit;

  Screen.Cursor := crHourGlass;

  AWallPaper := OpenDialog1.FileName;
  SystemParametersInfo(SPI_SETDESKWALLPAPER,
                       0,
                       PChar(AWallPaper),
                       SPIF_SENDCHANGE);
  Screen.Cursor := crDefault;
end;

//=============================================================================
//  元に戻す
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;

  SystemParametersInfo(SPI_SETDESKWALLPAPER,
                       0,
                       PChar(OrignalWallPaper),
                       SPIF_SENDCHANGE);
  Screen.Cursor := crDefault;
end;

end.



02_デスクトップの背景色の変更


参考までに，デスクトップの背景色は，GetSysColor 関数と SetSysColor 関数を使用して変更できます．これらの関数を使用すると，システムのいろいろな色を変更できます．


図4　
背景色変更前
図5　
背景色変更

リスト2　
デスクトップの背景色を変更 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    OrignalColor : TColor;
    Elements     : Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  現在の背景色を取得しておく
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //操作対象はデスクトップの背景色
  Elements := COLOR_DESKTOP;
  //元の色を退避しておく
  OrignalColor := GetSysColor(Elements);
end;

//=============================================================================
//  背景色を設定する
//  [画面のプロパティ]の[デスクトップ]の背景をなしにすると，この設定色になる
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  RGBValue : Integer;
begin
  Screen.Cursor := crHourGlass;

  //新しい背景色
  RGBValue := clSilver;
  //変更
  SetSysColors(1, Elements, RGBValue);

  Screen.Cursor := crDefault;
end;

//=============================================================================
//  元に戻す
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;

  SetSysColors(1, Elements, OrignalColor);

  Screen.Cursor := crDefault;
end;

end.



03_フォントスムージング


フォントスムージング機能は，フォントの境界を通常とは異なるグレースケールで表示することによってアンチエイリアシングを行い，フォントの曲線を滑らかに見せるものです．


表2
uiAction パラメータは SystemParametersInfo 関数の第 1 引数
uiParam は第 2 引数で，pvParam は第 3 引数

uiActionパラメータ uiParamとpvParamパラメータ
SPI_GETFONTSMOOTHING 取得
uiParam は 0
pvParam は整数値
有効になっている場合は 0 以外の値．それ以外の場合は 0
SPI_SETFONTSMOOTHING 設定
uiParam が 0 以外の時は有効に，0 の時は無効になる
pvParam は nil


図6
起動すると現在の設定を表示

リスト3　
フォントスムージング設定値の取得と設定 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    CheckBox1: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    OrignalValue : Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  プログラムを起動したら現在の設定を取得しておく
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  SystemParametersInfo(SPI_GETFONTSMOOTHING,
                       0,
                       OrignalValue,
                       0);

  CheckBox1.Checked := OrignalValue <> 0;
end;

//=============================================================================
//  スムージング地謡の変更
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AValue : Integer;
begin
  Screen.Cursor := crHourGlass;

  AValue := Ord(CheckBox1.Checked);
  SystemParametersInfo(SPI_SETFONTSMOOTHING,
                       AValue,
                       0,
                       SPIF_SENDCHANGE);
  Screen.Cursor := crDefault;
end;

//=============================================================================
//  元に戻す
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;

  SystemParametersInfo(SPI_SETFONTSMOOTHING,
                       OrignalValue,
                       0,
                       SPIF_SENDCHANGE);
  FormCreate(nil);
  Screen.Cursor := crDefault;
end;

end.



04_デスクトップの作業領域


デスクトップの作業領域とは，画面全体からシステムのタスクバーやアプリケーションのツールバーが占有する領域を除いた部分です．プライマリモニタ以外のモニタの場合は，GetMonitorInfo 関数等を使用して取得します．
このデスクトップ作業領域の取得と設定のサンプルです．作業領域を縮小すると，デスクトップのアイコンもその領域に合わせて再配置されてしまいます．


表3
uiAction パラメータは SystemParametersInfo 関数の第 1 引数
uiParam は第 2 引数で，pvParam は第 3 引数

uiActionパラメータ uiParamとpvParamパラメータ
SPI_GETWORKAREA 取得
RECT 構造体を使用
uiParam は 0
pvParam は RECT 構造体へのポインタ
この構造体に作業領域の座標が格納される
SPI_SETWORKAREA 設定
RECT 構造体を使用
uiParma は 0
pvParam は作業領域の RECT 構造体へのポインタ
nil にするとプライマリモニタの作業領域を画面全体に設定する


図7　起動すると現在の設定を表示

リスト4　
ワークエリアの取得と設定 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    LabeledEdit4: TLabeledEdit;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    OrignalRect : TRect;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  プログラムを起動したら現在の設定を取得しておく
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  SystemParametersInfo(SPI_GETWORKAREA,
                       0,
                       OrignalRect,
                       0);

  LabeledEdit1.Text := IntToStr(OrignalRect.Left);
  LabeledEdit2.Text := IntToStr(OrignalRect.Right);
  LabeledEdit3.Text := IntToStr(OrignalRect.Top);
  LabeledEdit4.Text := IntToStr(OrignalRect.Bottom);
end;

//=============================================================================
//  ワークエリアを設定
//  縮小すると，ウィンドウのサイズが設定した値以上にはできなくなる
//  デスクトップのアイコンもワークエリア内に再配置されてしまうので注意
//  現在の画面サイズより大きくはできない
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  ARect : TRect;
begin
  ARect.Left   := StrToIntDef(LabeledEdit1.Text, 100);
  ARect.Right  := StrToIntDef(LabeledEdit2.Text, 100);
  ARect.Top    := StrToIntDef(LabeledEdit3.Text, 100);
  ARect.Bottom := StrToIntDef(LabeledEdit4.Text, 100);

  SystemParametersInfo(SPI_SETWORKAREA,
                       0,
                       ARect,
                       SPIF_SENDCHANGE);
end;

//=============================================================================
//  元に戻す
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  SystemParametersInfo(SPI_SETWORKAREA,
                       0,
                       OrignalRect,
                       SPIF_SENDCHANGE);
  FormCreate(nil);
end;

end.


画面サイズ等は，GetSystemMetrics 関数や GetMonitorInfo でも取得できます．


リスト5　
画面サイズ等の取得 
//=============================================================================
//  TScreenオブジェクトを使用したスクリーンサイズの取得
//  ワークエリアではなくデスクトップのサイズの取得
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  ARect : TRect;
begin
  ListBox1.Items.Clear;
  SystemParametersInfo(SPI_GETWORKAREA,0,@ARect,0);

  ListBox1.Items.Add('左端 : ' + InttoStr(Screen.DesktopLeft));
  ListBox1.Items.Add('幅   : ' + InttoStr(Screen.DesktopWidth));
  ListBox1.Items.Add('上端 : ' + InttoStr(Screen.DesktopTop));
  ListBox1.Items.Add('高さ : ' + InttoStr(Screen.DesktopHeight));
end;

//=============================================================================
//  GetSystemMetrics関数を使用したプライマリモニターの画面サイズの取得
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  X : Integer;
  Y : Integer;
begin
  ListBox1.Clear;
  X := GetSystemMetrics(SM_CXSCREEN);
  Y := GetSystemMetrics(SM_CYSCREEN);

  ListBox1.Items.Add('横ドット : ' + InttoStr(X));
  ListBox1.Items.Add('縦ドット : ' + InttoStr(Y));
end;

//=============================================================================
//  GetMonitorInfo関数を使用したモニターのサイズの取得
//  usesにMultiMonが必要
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  MonitorHDC : HMONITOR;
  lpmi       : TMonitorInfo;
begin
  ListBox1.Clear;

  MonitorHDC  := Self.Monitor.Handle;
  lpmi.cbSize := SizeOf(lpmi);
  GetMonitorInfo(MonitorHDC, @lpmi);

  ListBox1.Items.Add('横ドット : ' + IntToStr(lpmi.rcMonitor.Right));
  ListBox1.Items.Add('縦ドット : ' + IntToStr(lpmi.rcMonitor.Bottom));
end;



05_タスクバーの情報と表示・非表示


SystemParametersInfo 関数のサンプルではありませんが，タスクバーの情報は SHAppBarMessage を使用して取得できます．また，タスクバーの表示と非表示は，タスクバーのハンドルで操作できます．


図8
実行例

リスト6
タスクバーの情報と表示・非表示の切り換え		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Panel1: TPanel;
    Panel2: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ShellAPI;

{$R *.dfm}

//=============================================================================
//  フォーム生成時にタスクバーの設定値を取得して表示
//  SH...関係の関数の使用には，usesにShellAPIが必要
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  AppBarData : TAppBarData;
  ARect      : TRect;
begin
  //タスクバーの大きさを取得
  AppBarData.cbSize := Sizeof(TAppBarData);
  SHAppBarMessage(ABM_GETTASKBARPOS, AppBarData);

  //取得した情報を表示
  ARect := AppBarData.rc;
  Panel1.Caption := '( ' +
                    IntToStr(ARect.Left)   + ', ' +
                    IntToStr(ARect.Top)    + ', ' +
                    IntToStr(ARect.Right)  + ', ' +
                    IntToStr(ARect.Bottom) + ' )';

  if (SHAppBarMessage(ABM_GETSTATE, AppBarData) and ABS_AUTOHIDE) > 0 then begin
    Panel2.Caption := '自動的に隠すに設定されています';
  end else begin
    Panel2.Caption := '自動的に隠すに設定されていません';
  end;
end;

//=============================================================================
//  本アプリ終了時には，タスクバーを表示するに設定する
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  Button2Click(nil);
end;

//=============================================================================
//  タスクバーを非表示にする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  hTray : HWND;
begin
  //タスクバーのハンドルを取得
  hTray := FindWindow('Shell_TrayWnd', nil);

  //非表示にする
  ShowWindow(hTray, SW_SHOWNOACTIVATE);
  ShowWindow(hTray, SW_HIDE);
end;

//=============================================================================
//  タスクバーを表示する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  hTray : HWND;
begin
  //タスクバーのハンドルを取得
  hTray := FindWindow('Shell_TrayWnd', nil);

  //表示する
  ShowWindow(hTray, SW_SHOWNA);
end;

end.



06_その他


以上のサンプルの他，以下のようなものがあります．


表4
uiAction パラメータは SystemParametersInfo 関数の第 1 引数
uiParam は第 2 引数で，pvParam は第 3 引数

uiAction パラメータ uiParam と pvParam パラメータ
SPI_SETCURSORS システムカーソルの再ロード
uiParam は 0
pvParam は nil
SPI_SETDESKPATTERN Win.ini ファイルの Pattern= エントリを読み込むよう Windows に指示し，デスクトップのパターンを設定
uiParam は 0
pvParam は nil




07_IActiveDesktop を使用したデスクトップの壁紙の変更


これも SystemParametersInfo 関数のサンプルではありませんが，IActiveDesktop インターフェイスを使用しても変更できます．そのサンプルです．


リスト7
IActiveDesktop を使用したデスクトップの壁紙の変更 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    OpenDialog1: TOpenDialog;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    OrignalWallPaper : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ShlObj, ComObj;

{$R *.dfm}

//=============================================================================
//  プログラムを起動したら現在の壁紙のフルパスを取得しておく
//  IActiveDesktopにはusesにShlObjが，CreateComObjectにはusesにComObjが必要
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  ActiveDesk : IActiveDesktop;
  Buff       : array [0..MAX_PATH-1] of Char;
begin
  ActiveDesk := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;

  FillChar(Buff, MAX_PATH, #0);
  ActiveDesk.GetWallpaper(@Buff, MAX_PATH, AD_GETWP_LAST_APPLIED);
  OrignalWallPaper := Buff;

  ActiveDesk := nil;
end;

//=============================================================================
//  壁紙変更
//  選択したビットマップが画面サイズで表示される
//  表示方法を変更したい場合はレジストリの操作が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  ActiveDesk : IActiveDesktop;
  AWallpaper : String;
begin
  OpenDialog1.Filter := 'ビットマップ|*.bmp';
  if OpenDialog1.InitialDir = '' then begin
    OpenDialog1.InitialDir := ExtractFileDir(Application.ExeName);
  end;
  if OpenDialog1.Execute = False then exit;

  Screen.Cursor := crHourGlass;

  ActiveDesk := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;

  AWallPaper := OpenDialog1.FileName;
  ActiveDesk.SetWallpaper(PChar(AWallpaper), 0);
  ActiveDesk.ApplyChanges(AD_APPLY_ALL);

  Screen.Cursor := crDefault;
  ActiveDesk := nil;
end;

//=============================================================================
//  元に戻す
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  ActiveDesk : IActiveDesktop;
begin
  Screen.Cursor := crHourGlass;

  ActiveDesk := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;

  ActiveDesk.SetWallpaper(PChar(OrignalWallPaper), 0);
  ActiveDesk.ApplyChanges(AD_APPLY_ALL);

  Screen.Cursor := crDefault;
  ActiveDesk := nil;
end;

end.



08_Windows 7 以降の壁紙スライドショーの設定


Windows 7 では壁紙のスライドショーが可能になっています．
slideshow.ini に表示画像を設定することでスライドショーにできます．slideshow.ini は以下の場所にあります．画像の切り替えの時間間隔はレジストリに設定します．単位はミリセコンドです．

  %APPDATA%\Microsoft\Windows\Themes\slideshow.ini

設定の更新をシステムに通知するためのコマンドやメッセージは実装されていないようです．したがって，このサンプルを実行しても，スライドショーはすぐには開始しません．
筆者の環境では，壁紙が表示されるまで，3 ～ 4 分程度かかりました．設定後，コンピュータを再起動すれば，起動直後から壁紙が表示されます．

壁紙のスライドショーを直ちに実行したい場合は，Windows XP までの時代のように，TTimer コンポーネントを使用して，一定時間間隔で壁紙を変更することになるでしょう．必要であれば，常駐アプリケーションにすることになります．


[備考 1]
下のコードでは，画像のパス名を，実際のパス名で指定しています．[コントロールパネル] の [個人設定] から壁紙のスライドショーを設定すると，項目識別子を Base64 でエンコードした文字列となっているようです．実パス名で指定しても動作することを確認したので，そのようにしています．
また，このサンプルでの設定は，MSDN の Custom.theme の説明に従っていますが，slideshow.ini もその記事の設定で動作するようです．

[備考 2]
壁紙を，スライドショー以外にすると，slideshow.ini の中身は自動的に空になります．


図9
Interval の値

リスト8
壁紙スライドショーの設定		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses IniFiles, Registry;

{$R *.dfm}

//---------------------------------------------------------------------------
//  環境変数を含む(%等の文字を含む)を実際のパス名に変換
//---------------------------------------------------------------------------
function ExpandEnvironmentString(S: String): String;
var
  DstChar : array [0..MAX_PATH - 1] of Char;
begin
  ExpandEnvironmentStrings(PChar(S), DstChar, MAX_PATH);
  Result := DstChar;
end;

//===========================================================================
//  壁紙のスライドショーの設定
//  Windows 7 以降用
//  usesにIniFiles, Registryが必要
//===========================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  IniPath   : String;
  aIniFile  : TIniFile;
  ImgDir    : String;
  Regist    : TRegistry;
  RegistKey : String;
begin
  //slideshow.iniの場所
  IniPath := '%APPDATA%\Microsoft\Windows\Themes\slideshow.ini';
  //環境変数を含む(%等の文字を含む)を実際のパス名に変換
  IniPath := ExpandEnvironmentString(IniPath);

  aIniFile := TIniFile.Create(IniPath);
  try
    ImgDir := ExpandFileName('Images');
    aIniFile.EraseSection('Slideshow');
    aIniFile.WriteInteger('Slideshow', 'Shuffle',        1);
    aIniFile.WriteString ('Slideshow', 'ImagesRootPath', ImgDir);
    aIniFile.WriteString ('Slideshow', 'Item0Path',      'Image001.JPG');
    aIniFile.WriteString ('Slideshow', 'Item1Path',      'Image002.JPG');
    aIniFile.WriteString ('Slideshow', 'Item2Path',      'Image003.JPG');
  finally
    FreeAndNil(aIniFile);
  end;

  //画像を更新する間隔(ここでは10秒)
  Regist := TRegistry.Create(KEY_READ or KEY_WRITE);
  try
    Regist.RootKey := HKEY_CURRENT_USER;
    RegistKey      := 'Control Panel\Personalization\Desktop Slideshow';
    if Regist.OpenKey(RegistKey, True) then begin
      Regist.WriteInteger('Interval', 10000);
    end;
  finally
    FreeAndNil(Regist);
  end;
end;

end.



09_Windows 8 以降の壁紙スライドショー  -  IDesktopWallpaper


Windows 8 でも，前項のサンプルを使用して壁紙のスライドショーを設定できますが，スライドショーを有効にするには，システムの再起動が必要です．

Windows 8 では，壁紙のスライドショー専用のインターフェイス IDesktopWallpaper が実装されています．このインターフェイスは，Delphi XE6 までには実装されていません．
そこで，ShObjIdl.idl ファイルからタイプライブラリを作成してユニットを作成しました．そのユニットのコードから，必要なインターフェイス部分だけを取り出して別のユニットにしました．
このユニットは，サンプルプログラムに添付しています．


図10
実行画面

サンプルを実行したら，Button1 をクリックします．すると，画像ファイルの選択ダイアログが表示されます．画像を複数選択すると，それらの画像を壁紙にしたスライドショーを開始します．


図11
画像を複数選択

リスト9
IDesktopWallpaper インターフェイス (Windows 8 以降) を使用した壁紙のスライドショー		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IDesktopWallpaper_TLB;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    FileOpenDialog1: TFileOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    pDeskTopWPaper   : IDesktopWallpaper;
    OriginWPaperPath : PChar;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ShlObj, ComObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  IDesktopWallpapeインターフェイスのインスタンスを生成
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.Enabled := False;
  Button2.Enabled := False;

  //Windows 8以上なら実行
  if CheckWin32Version(6, 2) then begin
    pDeskTopWPaper := CreateComObject(CLASS_DesktopWallpaper) as IDesktopWallpaper;
    //現在の壁紙の画像のフルパスを取得しておく
    pDeskTopWPaper.GetWallpaper(nil, OriginWPaperPath);

    Button1.Enabled := True;
    Button2.Enabled := True;
  end else begin
    MessageBox(Handle, 'Windows 8 以上用です', '情報', MB_ICONINFORMATION);
  end;
end;

//=============================================================================
//  スライドショーに使用する画像を選択して，スライドショー開始
//  TFileOpenDialogダイアログを表示して，画像ファイルを選択する
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  ImagePath  : String;
  pItemArray : IShellItemArray;
begin
  ImagePath := ExpandFileName('Images');

  FileOpenDialog1.DefaultFolder := ImagePath;
  //選択可能な画像はJPEGとPNGのみとする
  with FileOpenDialog1.FileTypes.Add do begin
    DisplayName := '画像ファイル';
    FileMask    := '*.jpg;*.png';
  end;
  //スライドショーなので，複数の画像を選択可能にする
  FileOpenDialog1.Options := FileOpenDialog1.Options + [fdoAllowMultiSelect];

  if FileOpenDialog1.Execute then begin
    pItemArray := FileOpenDialog1.ShellItems;

    //スライドショー開始
    pDeskTopWPaper.SetSlideshowOptions(0, 1000);
    pDeskTopWPaper.SetSlideshow(pItemArray);
  end;
end;

//=============================================================================
//  元に戻す
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  pDeskTopWPaper.SetWallpaper(nil, OriginWPaperPath);
end;

end.


リスト10
添付している IDesktopWallpaper インターフェイスのコード		 
unit IDesktopWallpaper_TLB;

interface

uses Windows, Classes, Variants, ActiveX, ShlObj;

const
  IID_IDesktopWallpaper: TGUID = '{B92B56A9-8B55-4E14-9A89-0199BBB6F93B}';
  CLASS_DesktopWallpaper: TGUID = '{C2CF3110-460E-4FC1-B9D0-8A1C0C9CC4BD}';

// *********************************************************************//
// タイプ ライブラリで定義された列挙型の宣言
// *********************************************************************//

// 列挙型 DESKTOP_WALLPAPER_POSITION の定数
type
  DESKTOP_WALLPAPER_POSITION = TOleEnum;
const
  DWPOS_CENTER  = $00000000;
  DWPOS_TILE    = $00000001;
  DWPOS_STRETCH = $00000002;
  DWPOS_FIT     = $00000003;
  DWPOS_FILL    = $00000004;
  DWPOS_SPAN    = $00000005;

// 列挙型 DESKTOP_SLIDESHOW_OPTIONS の定数
type
  DESKTOP_SLIDESHOW_OPTIONS = TOleEnum;
const
  DSO_SHUFFLEIMAGES = $00000001;

// 列挙型 DESKTOP_SLIDESHOW_DIRECTION の定数
type
  DESKTOP_SLIDESHOW_DIRECTION = TOleEnum;
const
  DSD_FORWARD  = $00000000;
  DSD_BACKWARD = $00000001;

// 列挙型 DESKTOP_SLIDESHOW_STATE の定数
type
  DESKTOP_SLIDESHOW_STATE = TOleEnum;
const
  DSS_ENABLED    = $00000001;
  DSS_SLIDESHOW  = $00000002;
  DSS_DISABLED_BY_REMOTE_SESSION = $00000004;

type

// *********************************************************************//
// インターフェイス: IDesktopWallpaper
// フラグ: (0)
// GUID: {B92B56A9-8B55-4E14-9A89-0199BBB6F93B}
// *********************************************************************//
  IDesktopWallpaper = interface(IUnknown)
    ['{B92B56A9-8B55-4E14-9A89-0199BBB6F93B}']
    function SetWallpaper(monitorID: PWideChar; wallpaper: PWideChar): 
      HResult; stdcall;
    function GetWallpaper(monitorID: PWideChar; out wallpaper: PWideChar): 
      HResult; stdcall;
    function GetMonitorDevicePathAt(monitorIndex: SYSUINT; 
      out monitorID: PWideChar): HResult; stdcall;
    function GetMonitorDevicePathCount(out count: SYSUINT): HResult; stdcall;
    function GetMonitorRECT(monitorID: PWideChar; out displayRect: TRect):
      HResult; stdcall;
    function SetBackgroundColor(color: LongWord): HResult; stdcall;
    function GetBackgroundColor(out color: LongWord): HResult; stdcall;
    function SetPosition(position: DESKTOP_WALLPAPER_POSITION): HResult; stdcall;
    function GetPosition(out position: DESKTOP_WALLPAPER_POSITION): HResult; stdcall;
    function SetSlideshow(const items: IShellItemArray): HResult; stdcall;
    function GetSlideshow(out items: IShellItemArray): HResult; stdcall;
    function SetSlideshowOptions(options: DESKTOP_SLIDESHOW_OPTIONS; 
      slideshowTick: SYSUINT): HResult; stdcall;
    function GetSlideshowOptions(out options: DESKTOP_SLIDESHOW_OPTIONS; 
      out slideshowTick: SYSUINT): HResult; stdcall;
    function AdvanceSlideshow(monitorID: PWideChar; 
      direction: DESKTOP_SLIDESHOW_DIRECTION): HResult; stdcall;
    function GetStatus(out state: DESKTOP_SLIDESHOW_STATE): HResult; stdcall;
    function Enable(Enable: Integer): HResult; stdcall;
  end;

implementation

end.