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.