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.