ホーム >プログラム >Delphi 6 ローテクTips >WindowsMediaPlayerで壁紙ビデオ

TMediaPlayerで壁紙ビデオができました。
次はせっかく苦労してTWindowsMediaPlayerでサイズ変更できるようになったのですから、TWindowsMediaPlayerでも壁紙ビデオを実現させたい、と。
そう思ったわけです。

とはいえこれはXPでしか実現できません。
Windows 7(多分Vistaでも)のWindowsMediaPlayerではハードウェアオーバーレイを使わないように変わったためです。


下準備
WindowsMediaPlayer1をダブルクリックして出てくる設定画面で「コントロールのレイアウト」の「モードの選択」でNoneを選びます。
シークバーやコントロールボタンのないビデオを表示する画面だけのモードです。
「ウィンドウに合わせる」にチェックを入れておかないと拡大はできません。
最大でオリジナルのビデオサイズまでになります。
逆に拡大させたくなければチェックを外しておくと良いでしょう(縮小はされます)
「自動的に開始する」にチェックを入れておくとURLプロパティにファイル名をセットするだけで再生が開始されるので手間を少し省けます。
実装
WindowsMediaPlayerのサイズ変更をするためにActiveXをusesに加えます。
implementaiton
uses
  ActiveX,
  wallpaper;


procedure TForm1.FormCreate(Sender: TObject);
begin
  Form2 := TForm2.Create(Self);
  Form2.BorderStyle := bsNone;  //必須
  Form2.SetBounds(0, 0, 0, 0);
  Form2.Show;  //必須
  WindowsMediaPlayer1.ManualDock(Form2);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if (OpenDialog1.Execute) then begin
    MediaPlayer1.URL := OpenDialog1.FileName;
//    MediaPlayer1.controls.play;  //「自動的に開始する」にチェックを入れていれば必要なし
  end;
end;

procedure TForm1.WindowsMediaPlayer1PlayStateChange(Sender: TObject; NewState: Integer);
const
  IID_IOleInPlaceObject: TGUID = '{00000113-0000-0000-C000-000000000046}';
var
  IOIPObj:  IOleInPlaceObject;
begin
  if (NewState = wmppsPlaying) then begin
    //再生の始めか再開のときにここにくる
    if (WindowsMediaPlayer1.currentMedia.imageSourceHeight > 0) or (WindowsMediaPlayer1.currentMedia.imageSourceWidth > 0) then begin
      //映像あり
      gpcWallVideoInit;
      WindowsMediaPlayer1.BoundsRect := Screen.WorkAreaRect;
      IDispatch(WindowsMediaPlayer1.OleObject).QueryInterface(IID_IOleInPlaceObject, IOIPObj);
      IOIPObj.SetObjectRects(WindowsMediaPlayer1.BoundsRect, WindowsMediaPlayer1.BoundsRect);
    end else begin
      //映像なし
      gpcWallVideoFree;
    end;
  end;
end;
この例ではビデオのアスペクト比によっては画面の上下左右に隙間ができます。
隙間なく拡大したければMediaPlayerでやったようにオリジナルサイズからアスペクト比を計算して画面にあてはめてWindowsMediaPlayerのBoundsRectプロパティにセットします。
注意点としてはMediaPlayerの時と違ってRect値をセットします。
WindowsMediaPlayer.BoundsRect := Rect(Left, Top, Right, Bottom);
といった感じです。
WidthとHeightではなくRightとBottomになります。
サンプルプログラム
簡単なサンプルプログラムです。
壁紙ビデオのセットアップ用クラスを使わずに書いているのでこちらの方が分かりやすいかも知れません。
また壁紙ビデオにするときはWindowsMediaPlayerの親ウィンドウをデスクトップにしてしまうことでサブフォームのForm2を使わずに済ませています。
unit main;
//{$DEFINE BGCOLOR}
//背景色をいじらない場合はコメントアウトにする。
//背景色をいじらない方が多少システムへの影響が少ない。

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, MPlayer, StdCtrls, ExtCtrls, OleCtrls, WMPLib_TLB, Buttons;

type
  TForm1 = class(TForm)
    Panel1:       TPanel;
    ComboBox1:    TComboBox;
    Panel2:       TPanel;
    Button1:      TButton;
    Button2:      TButton;
    CheckBox1:    TCheckBox;
    OpenDialog1:  TOpenDialog;
    WindowsMediaPlayer1: TWindowsMediaPlayer;
    SpeedButton1: TSpeedButton;
    procedure FormCreate (Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize (Sender: TObject);
    procedure SpeedButton1Click (Sender: TObject);
    procedure Button1Click      (Sender: TObject);
    procedure Button2Click      (Sender: TObject);
    procedure CheckBox1Click    (Sender: TObject);
    procedure ComboBox1Select   (Sender: TObject);
    procedure WindowsMediaPlayer1OpenStateChange(Sender: TObject; NewState: Integer);
    procedure WindowsMediaPlayer1PlayStateChange(Sender: TObject; NewState: Integer);
    procedure WindowsMediaPlayer1MediaError     (Sender: TObject; const pMediaObject: IDispatch);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private 宣言 }
    F_bMediaEnded: Boolean;
    F_iErrorCount: Integer;

    F_bMediaIsVideo: Boolean;
    F_iMediaWidth, F_iMediaHeight: Integer;
    F_bWallvideo: Boolean;
    F_sWallpaper: String;
    {$IFDEF BGCOLOR}
    F_clBGColor:  TColor;
    {$ENDIF}

    procedure F_Play(iIndex: Integer);
    procedure F_SetWallvideo;
    procedure F_ResetWallvideo;
    procedure AppMessage(var Msg: TMessage); message WM_APP;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation
uses
  ActiveX,
  CommCtrl;


{$R *.dfm}


function gfnsWallPaperGet: String;
//壁紙取得
const
  //Windows2000以降で壁紙のファイル名を取得
  SPI_GETDESKWALLPAPER = 115;
var
  lp_Buff: PChar;
begin
  lp_Buff := AllocMem(MAX_PATH+1);
  try
    SystemParametersInfo(SPI_GETDESKWALLPAPER, MAX_PATH, lp_Buff, 0);
    Result := String(lp_Buff);
  finally
    FreeMem(lp_Buff);
  end;
end;

procedure gpcWallPaperSet(sFile: String);
//壁紙セット
begin
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar(sFile), 0);
//  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar(sFile), SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
end;


{$IFDEF BGCOLOR}
//背景色 -----------------------------------------------------------------------
function gfniDesktopColorGet: DWORD;
begin
  Result := GetSysColor(COLOR_BACKGROUND);
end;

procedure gpcDesktopColorSet(iColor: DWORD);
var
  li_Element: Integer;
begin
  //デスクトップの背景色を変更
  li_Element := COLOR_BACKGROUND;
  SetSysColors(1, li_Element, iColor);
end;
{$ENDIF}


procedure gpcWMPSetBounds(plyWMP: TWindowsMediaPlayer; iLeft, iTop, iWidth, iHeight: Integer);
//WindowsMediaPlayerのサイズをセット
//http://www1.rocketbbs.com/312/bbs.cgi?id=fjtkt&mode=pickup&no=214
const
  lcID_IOLE_INPLACEOBJECT: TGUID = '{00000113-0000-0000-C000-000000000046}';
var
  lI_Obj: IOleInPlaceObject;
  lrc_Rect: TRect;
begin
  lrc_Rect := Rect(iLeft, iTop, iLeft + iWidth, iTop + iHeight);
  IDispatch(plyWMP.OleObject).QueryInterface(lcID_IOLE_INPLACEOBJECT, lI_Obj);
  lI_Obj.SetObjectRects(lrc_Rect, lrc_Rect);
  //↓はあった方が連続してサイズ変更したときにちらつきが少ない(ように思う)
  Application.ProcessMessages;
end;


function gfnsClassNameGet(hHandle: HWND): String;
{2007-06-09:
ウィンドウハンドルhHandleのクラス名を返す
}

const
  lci_LEN = 256;
var
  lp_Buff: PChar;
begin
  Result := '';
  lp_Buff := AllocMem(lci_LEN +1);
  try
    GetClassName(hHandle, lp_Buff, lci_LEN -1);
    Result := String(lp_Buff);
  finally
    FreeMem(lp_Buff);
  end;
end;

function gfnsWindowTextGet(hHandle: HWND): String;
//ウィンドウハンドルhHandleのテキスト(キャプション)を返す
var
  li_Len:  Integer;
  lp_Buff: PChar;
begin
  Result := '';
  li_Len := GetWindowTextLength(hHandle) +1;
  if (li_Len > 0) then begin
    lp_Buff := AllocMem(li_Len);
    try
      GetWindowText(hHandle, lp_Buff, li_Len);
      Result := String(lp_Buff);
    finally
      FreeMem(lp_Buff);
    end;
  end;
end;

function gfnhDesktopListViewWindowGet: HWND;
//デスクトップのリストビューのハンドルを取得
//このリストビューを壁紙ビデオのときWindowsMediaPlayer1の親ウィンドウにしてしまう
  function lfnb_ChildWindowProc(hHandle: HWND; pResult: Pointer): BOOL; stdcall;
  begin
    if (gfnsClassNameGet(hHandle) = WC_LISTVIEW) then begin
      HWND(pResult^) := hHandle;
      Result := False;
    end else begin
      Result := True;
    end;
  end;
  function lfnb_WindowProc(hWindow: HWND; pResult: Pointer): BOOL stdcall;
  begin
    if  (IsWindowVisible(hWindow))
    and (gfnsClassNameGet(hWindow)  = 'Progman')
    and (gfnsWindowTextGet(hWindow) = 'Program Manager')
    then begin
      HWND(pResult^) := hWindow;
    end;
    Result := True;
  end;
begin
  Result := 0;
  EnumWindows(@lfnb_WindowProc, LPARAM(@Result));
  if (Result <> 0) then begin
    EnumChildWindows(Result, @lfnb_ChildWindowProc, LPARAM(@Result));
  end;
end;


//------------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
  Color := $100010;

  F_bWallvideo := False;
  F_sWallpaper := '';
  {$IFDEF BGCOLOR}
  F_clBGColor := clBackground;
  {$ENDIF}

  AnimateWindow(Handle, 500, AW_BLEND or AW_ACTIVATE);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  AnimateWindow(Handle, 500, AW_BLEND or AW_HIDE);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  F_ResetWallvideo;
end;

//ビデオサイズの調整
procedure TForm1.FormResize(Sender: TObject);
begin
  if (GetParent(WindowsMediaPlayer1.Handle) = Self.Handle) then begin
    gpcWMPSetBounds(WindowsMediaPlayer1, 0, Panel1.Height, ClientWidth, ClientHeight - Panel1.Height - Panel2.Height);
  end;
end;

//再生/一時停止
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  if (WindowsMediaPlayer1.currentMedia <> nil) then begin
    if (WindowsMediaPlayer1.playState = wmppsPlaying) then begin
      WindowsMediaPlayer1.controls.pause;
    end else begin
      WindowsMediaPlayer1.controls.play;
    end;
  end;
end;

//リストに追加
procedure TForm1.Button1Click(Sender: TObject);
var
  li_Index: Integer;
begin
  if (OpenDialog1.Execute) then begin
    li_Index := ComboBox1.Items.Count;
    ComboBox1.Items.AddStrings(OpenDialog1.Files);
    F_Play(li_Index);
  end;
end;

//リストをクリア
procedure TForm1.Button2Click(Sender: TObject);
begin
  ComboBox1.Items.Clear;
end;

//壁紙ビデオのオンオフ
procedure TForm1.CheckBox1Click(Sender: TObject);
var
  lf_Aspect: Extended;
  li_Left, li_Top, li_Width, li_Height: Integer; //ビデオの拡大サイズ
begin
  if (F_bMediaIsVideo) and (CheckBox1.Checked) then begin
    F_SetWallvideo;

    //WindowsMediaPlayerの親ウィンドウをデスクトップにする
    Windows.SetParent(WindowsMediaPlayer1.Handle, gfnhDesktopListViewWindowGet);
    WindowsMediaPlayer1.Visible := False;

    //アスペクト比を保って画面いっぱいになるように
    lf_Aspect := F_iMediaHeight / F_iMediaWidth;
    li_Width  := Screen.WorkAreaWidth;
    li_Height := Trunc(li_Width * lf_Aspect);
    if (li_Height < Screen.WorkAreaHeight) then begin
      li_Height := Screen.WorkAreaHeight;
      li_Width := Trunc(li_Height / lf_Aspect);
    end;
    //画面の中央に表示するため
    li_Left := (Screen.WorkAreaWidth  - li_Width)  div 2;
    li_Top  := (Screen.WorkAreaHeight - li_Height) div 2;
    gpcWMPSetBounds(WindowsMediaPlayer1, li_Left, li_Top, li_Width, li_Height);
  end else begin
    F_ResetWallvideo;
    Windows.SetParent(WindowsMediaPlayer1.Handle, Self.Handle);
    if (F_bMediaIsVideo) then begin
      //ビデオのアスペクト比に合わせて高さを調整
      Self.ClientHeight := Trunc(ClientWidth * (F_iMediaHeight / F_iMediaWidth)) + Panel1.Height + Panel2.Height;
    end;
    FormResize(nil);
    WindowsMediaPlayer1.Visible := True;
  end;
end;

//リストから選択
procedure TForm1.ComboBox1Select(Sender: TObject);
begin
  F_Play(ComboBox1.ItemIndex);
end;

procedure TForm1.AppMessage(var Msg: TMessage);
begin
  F_Play(ComboBox1.ItemIndex);
end;

procedure TForm1.F_Play(iIndex: Integer);
begin
  ComboBox1.ItemIndex := iIndex;
  WindowsMediaPlayer1.URL := ComboBox1.Items[iIndex];
  WindowsMediaPlayer1.controls.play;
end;

procedure TForm1.F_SetWallvideo;
{$IFNDEF BGCOLOR}
var
  l_Bitmap: TBitmap;
  ls_File:  String;
{$ENDIF}
begin
  if not(F_bWallvideo) then begin
    //背景を退避
    F_sWallpaper := gfnsWallpaperGet;
    {$IFNDEF BGCOLOR}
      //背景色を変えない場合
      //$100010に塗りつぶしたスクリーンいっぱいの画像を作り壁紙にセットしてしまう
      ls_File  := ChangeFileExt(ParamStr(0), '.bmp');
      l_Bitmap := TBitmap.Create;
      try
        //スクリーンいっぱいのサイズにする
        l_Bitmap.Width  := Screen.Width;
        l_Bitmap.Height := Screen.Height;
        //オーバーレイ色で塗りつぶす
        l_Bitmap.Canvas.Brush.Color := $100010;
        l_Bitmap.Canvas.FillRect(Rect(0, 0, l_Bitmap.Width, l_Bitmap.Height));
        l_Bitmap.SaveToFile(ls_File);
        //壁紙にセット
        gpcWallpaperSet(ls_File);
      finally
        l_Bitmap.Free;
      end;
    {$ELSE}
      //背景色を変える場合
      F_clBGColor  := gfniDesktopColorGet;
      //背景を壁紙ビデオ用にセット
      gpcWallpaperSet('');
      gpcDesktopColorSet($100010);
    {$ENDIF}
    F_bWallvideo := True;
  end;
end;

procedure TForm1.F_ResetWallvideo;
begin
  //背景を戻す
  if (F_bWallvideo) then begin
    gpcWallpaperSet(F_sWallpaper);
    {$IFDEF BGCOLOR}
    gpcDesktopColorSet(F_clBGColor);
    {$ENDIF}
    F_bWallvideo := False;
  end;
end;


procedure TForm1.WindowsMediaPlayer1OpenStateChange(Sender: TObject; NewState: Integer);
begin
  if (NewState = wmposMediaOpen) then begin
    F_iMediaWidth  := WindowsMediaPlayer1.currentMedia.imageSourceWidth;
    F_iMediaHeight := WindowsMediaPlayer1.currentMedia.imageSourceHeight;
    //メディアの高さと幅が0より大きければビデオがある
    F_bMediaIsVideo := (F_iMediaWidth > 0) and (F_iMediaHeight > 0);
    CheckBox1.OnClick(nil); //壁紙ビデオ
  end;
end;

procedure TForm1.WindowsMediaPlayer1PlayStateChange(Sender: TObject; NewState: Integer);
begin
  case NewState of
    wmppsMediaEnded: begin
      //「Stop」ボタンを押して停止させようとしたのかそうでないのかの判定のために必要
      if (ComboBox1.ItemIndex = ComboBox1.Items.Count-1) then begin
        ComboBox1.ItemIndex := 0;
      end else begin
        ComboBox1.ItemIndex := ComboBox1.ItemIndex +1;
      end;
      F_bMediaEnded := True;
    end;
    wmppsStopped: begin
      //wmppsMediaEndedを通ったかどうかで「Stop」ボタンを押したのかどうかの判定をしている
      if (F_bMediaEnded) then begin
        //wmppsMediaEndedを通ったので停止させず連続再生させる
        PostMessage(Handle, WM_APP, 0, 0);
      end;
      F_bMediaEnded := False;
    end;
    wmppsReady: begin
      //*.flvファイルなどは2回エラーが起き、最初だけplayさせればOK
      if (F_iErrorCount = 1) then begin
        if (Assigned(WindowsMediaPlayer1.currentMedia)) then begin
          WindowsMediaPlayer1.controls.play;
        end;
      end else  begin
        F_iErrorCount := 0;
      end;
    end;
  end;
end;

//メディアエラー
procedure TForm1.WindowsMediaPlayer1MediaError(Sender: TObject; const pMediaObject: IDispatch);
begin
  Inc(F_iErrorCount);
end;

end.

イメージ映像(画面ははめ込み合成)
こんな感じになります。

wallvideo_wmp.zip サンプルコードと実行ファイルの詰め合わせ。


プレーヤーのサイズ変更に関してはTWindowsMediaPlayerのサイズ変更を参照。
連続再生に関してはTWindowsMediaPlayerのタイミングを参照。