Unicode対応のTMeiaPlayerのサブセット版

unit myMPlayer;

interface
uses
  Classes, MMSystem, Windows, Messages, MPlayer;

type
{MyPlayer}
{2007-09-26:
Delphi MPlayer.pasのTMediaPlayerから必要なものだけを抽出。
ファイル名のUnicode対応。
ビデオディスプレイの指定にウィンドウハンドルを指定するようにしているので他のプロ
グラムのウィンドウを指定することも可能。
だからどうしたということでもあるけれど。
}
  TMyPlayer = class(TComponent)
  private
    F_iCmdError,
    F_iError:         MCIERROR;
    F_hHandle:        HWND;
    F_iDeviceID:      Integer;
    F_iLength:        Longint;
    F_iTimeFormat:    Longint;
    F_bHasVideo:      Boolean;
    F_hDisplayWindow: HWND;  //ウィンドウハンドルなら何でもOK。
    F_rcDisplayRect:  TRect;
    F_iVideoWidth,
    F_iVideoHeight:   Integer;
    F_sFileName:      WideString;  //メディアのファイル名。

    function F_GetMediaAssigned: Boolean;
    function F_GetMediaAspect:   Extended;
    function F_GetPlayMode:      DWORD;
    function F_GetMode:          TMPModes;
    function F_GetMediaPosition: Longint;
    function F_GetMediaLength:   Longint;
    function F_GetFilePath:      WideString;
    function F_GetFileName:      WideString;
    function F_GetFileExt:       WideString;
    procedure F_SetMediaPosition(const iPos: Longint);
    procedure F_SetTimeFormat   (const iFormat: Longint);
    procedure F_SetDisplayWindow(const hHandle: HWND);
    procedure F_SetDisplayRect  (const rcRect: TRect);
    procedure F_SetVideoShow    (const bShow: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function Open(sFile: WideString): Boolean; overload;
    function Open:      Boolean; overload;
    function Close:     Boolean;
    function Play:      Boolean; overload;
    function Play(iPos: Longint): Boolean; overload;
    function Pause:     Boolean;
    function Resume:    Boolean;
    function Rewind:    Boolean;
    function Replay:    Boolean;
    function Stop:      Boolean;

    property DisplayRect: TRect      read F_rcDisplayRect    write F_SetDisplayRect;
    property FileName:    WideString read F_sFileName        write F_sFileName;
    property Length:      Longint    read F_iLength;
    property Mode:        TMPModes   read F_GetMode;
    property Position:    Longint    read F_GetMediaPosition write F_SetMediaPosition;

    property DisplayWindow: HWND       read F_hDisplayWindow write F_SetDisplayWindow;
    property PlayMode:      DWORD      read F_GetPlayMode;
    property TimeFormat:    Longint    read F_iTimeFormat    write F_SetTimeFormat;
    property VideoShow:     Boolean                          write F_SetVideoShow;

    property MediaAssigned: Boolean    read F_GetMediaAssigned;
    property MediaPosition: Longint    read F_GetMediaPosition write F_SetMediaPosition;
    property MediaLength:   Longint    read F_iLength;
    property MediaHasVideo: Boolean    read F_bHasVideo;
    property MediaWidth:    Integer    read F_iVideoWidth;
    property MediaHeight:   Integer    read F_iVideoHeight;
    property MediaAspect:   Extended   read F_GetMediaAspect;
    property MediaFileName: WideString read F_sFileName;
    property MediaPath:     WideString read F_GetFilePath;
    property MediaName:     WideString read F_GetFileName;
    property MediaExt:      WideString read F_GetFileExt;
  end;



//==============================================================================
implementation
uses
//  myDebug,
  Controls,
//  myFile,
//  mySize;
  Forms;


//==============================================================================
//汎用ルーチン始まり

//myFile.pas
//ファイル属性
{
faReadOnly  $00000001  読み出し専用ファイル
faHidden    $00000002  非表示ファイル
faSysFile    $00000004  システムファイル
faVolumeID  $00000008  ボリュームファイル
faDirectory  $00000010  ディレクトリファイル
faArchive    $00000020  アーカイブファイル
faAnyFile    $0000003F  すべてのファイル

FILE_ATTRIBUTE_READONLY    ファイルは書き込み禁止属性です。アプリケーションは､ ファイルの読み取りはできますが､ 書き込みや削除はできません。
FILE_ATTRIBUTE_HIDDEN      ファイルは隠し属性です。通常のディレクトリ リスティングには､ このファイルは含まれません。
FILE_ATTRIBUTE_SYSTEM      ファイルはオペレーティング システムの一部です。または､ オペレーティング システム専用のファイルとして使われます。

FILE_ATTRIBUTE_DIRECTORY  ファイルはディレクトリです。
FILE_ATTRIBUTE_ARCHIVE    ファイルはアーカイブ ファイルです。アプリケーションはこのフラグを､ バックアップまたは削除のためにファイルをマークするのに使います。

FILE_ATTRIBUTE_NORMAL      ファイルには､ これ以外のほかの属性はありません。この属性は､ 単独で指定したときだけ有効です。
FILE_ATTRIBUTE_TEMPORARY  ファイルは一時的な記憶域として使用されています。アプリケーションはファイルへの書き込みができますが､ どうしても必要なときだけに限られます。一時ファイルはある程度時間が経過すると削除されてしまうため､ ファイルのデータのほとんどはメモリ内に残され､ ディスクなどのメディアにフラッシュされることはありません。
FILE_ATTRIBUTE_COMPRESSED
FILE_ATTRIBUTE_OFFLINE
}
function gfniFileAttrGet(sFile: WideString; bFileOnly: Boolean): Integer; overload;
{2007-08-28,2008-02-20,12-26:
sFileのファイル属性を返す。
ドライブ名のみは無効(-1を返す)。
bFileOnlyがTrueならディレクトリは無視する。

2008-12-26:FileGetAttrに合わせた仕様に変更。
2008-02-20:ワイルドカードを指定した時に正しい値を返さない不具合を修正。
}
var
  lh_Handle: THandle;
  lr_Info:   TWin32FindDataW;
  li_Len:    Integer;
begin
//  Result := Integer(GetFileAttributesW(PWideChar(sFile)));

  Result := -1;

  if (sFile <> '') then begin
    li_Len := Length(sFile);
    if (sFile[li_Len] = '\') then begin
      SetLength(sFile, li_Len -1);
    end;
  end;

  FillChar(lr_Info, SizeOf(TWin32FindDataW), 0);
  lh_Handle:= FindFirstFileW(PWideChar(sFile), lr_Info);
  try
    if (lh_Handle<> INVALID_HANDLE_VALUE) then begin
      repeat
        if  (WideString(lr_Info.cFileName) <> '.')
        and (WideString(lr_Info.cFileName) <> '..')
        then begin
          if (bFileOnly = False)
          or ((bFileOnly) and ((lr_Info.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0))
          then begin
            //bFileOnlyがFalse
            //または bFileOnlyがTrueでかつディレクトリではななかった
            Result := Integer(lr_Info.dwFileAttributes);
            Break;
          end;
        end;
      until not(FindNextFileW(lh_Handle, lr_Info));
    end;
  finally
    Windows.FindClose(lh_Handle);
  end;
end;

function gfniFileAttrGet(sFile: WideString): Integer; overload;
begin
  if (Pos('*', sFile) > 0)
  or (Pos('?', sFile) > 0)
  then begin
    Result := gfniFileAttrGet(sFile, False);
  end else begin
    Result := Integer(GetFileAttributesW(PWideChar(sFile)));
  end;
end;

function gfnsFilePathGet(sFile: WideString): WideString;
{2007-07-27,10-26:
Unicode対応ExtractFilePath。
ドライブ名も含む。
末尾の'\'はつく。
ドライブ名のみの場合も'\'はつく。
ただしパスが空文字の場合のみ'\'はつかない。

2007-10-26:パスが空文字の場合'\'をつけないことにした。
}
var
  i: Integer;
begin
  Result := '';
  if (sFile <> '')
  then begin
    for i := Length(sFile) downto 1
    do begin
      if (sFile[i] = '\')
      or (sFile[i] = '/')
      then begin
        Result := Copy(sFile, 1, i);
    Break;
      end
      else
      if (sFile[i] = ':')
      then begin
        Result := Copy(sFile, 1, i) + '\';
    Break;
      end;
    end;
  end;
end;

function gfnbFolderExists(sFolder: WideString): Boolean;
{2007-07-27,2008-02-20,2008-04-24:
DirectoryExistsのWideString対応版

2008-02-20:sFileにワイルドカードが指定された時の対処
2008-04-24:sFileの末尾に'\'があるとエラーになることへの対処
}
var
  lh_Handle: THandle;
  lr_Info:   TWin32FindDataW;
  li_Len:    Integer;
  li_Attr:   DWORD;
begin
  Result := False;
  if (sFolder = '') then Exit;

  if (Pos('*', sFolder) > 0)
  or (Pos('?', sFolder) > 0)
  then begin
    if (sFolder <> '') then begin
      li_Len := Length(sFolder);
      if (sFolder[li_Len] = '\') then begin
        SetLength(sFolder, li_Len-1);
      end;
    end;

    FillChar(lr_Info, SizeOf(TWin32FindDataW), 0);
    lh_Handle:= FindFirstFileW(PWideChar(sFolder), lr_Info);
    try
      if (lh_Handle<> INVALID_HANDLE_VALUE) then begin
        repeat
          if  (WideString(lr_Info.cFileName) <> '.')
          and (WideString(lr_Info.cFileName) <> '..')
          and ((lr_Info.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0)
          then begin
            Result := True;
            Break;
          end;
        until not(FindNextFileW(lh_Handle, lr_Info));
      end;
    finally
      Windows.FindClose(lh_Handle);
    end;
  end else begin
    li_Attr := GetFileAttributesW(PWideChar(sFolder));
    Result  := (li_Attr <> $FFFFFFFF) and ((li_Attr and FILE_ATTRIBUTE_DIRECTORY) <> 0);
  end;
end;

function gfnbFileExists(sFile: WideString): Boolean;
{2007-07-27:
FileExitsのUnicode対応版
}
var
  li_Attr: DWORD;
begin
  Result := False;
  if (sFile = '') then Exit;

  if (Pos('*', sFile) > 0)
  or (Pos('?', sFile) > 0)
  then begin
    if (gfnbFolderExists(gfnsFilePathGet(sFile))) then begin
      li_Attr := gfniFileAttrGet(sFile, True);
      Result  := (li_Attr <> $FFFFFFFF) and ((li_Attr and FILE_ATTRIBUTE_DIRECTORY) = 0);
    end;
  end else begin
    li_Attr := GetFileAttributesW(PWideChar(sFile));
    Result  := (li_Attr <> $FFFFFFFF) and ((li_Attr and FILE_ATTRIBUTE_DIRECTORY) = 0);
  end;
end;

function gfnsFileNameGet(sFile: WideString): WideString;
{2007-08-05:
パスを除いたファイル名を返す。
拡張子はつく。
'\'はつかない。
}
var
  i, li_Len, li_Pos: Integer;
begin
  Result := '';
  if (sFile <> '') then begin
    li_Len := Length(sFile);
    li_Pos := li_Len + 1;  //sFileの最後が'\'であった場合への対策
    for i := li_Len downto 1 do begin
      if (sFile[i] = '\') or (sFile[i] = '/') or(sFile[i] = ':') then begin
    Break;
      end;
      li_Pos := i;
    end;
    Result := Copy(sFile, li_Pos, MaxInt);
  end;
end;

function gfnsFileExtGet(sFile: WideString): WideString;
{2007-08-05,2008-12-27:
Unicode対応ExtractFileExt。
'.'は返る

2008-12-27:'.'のないファイル名のみの場合sFileすべてを返してしまう間違いを修正。
}
var
  i: Integer;
begin
  Result := '';
  for i := Length(sFile) downto 1 do begin
    if (sFile[i] = '\') or (sFile[i] = '/') or (sFile[i] = ':') then begin
      //拡張子なし
  Break;
    end else if (sFile[i] = '.') then begin
      //拡張子あり
      Result := Copy(sFile, i, MaxInt);
  Break;
    end;
  end;
end;

//mySize.pas
function gfniRectWidth(rtRect: TRect): Integer;
{2007-06-09:
rtRectの幅を返す
}
begin
  with rtRect do begin
    Result := Right - Left;
  end;
end;

function gfniRectHeight(rtRect: TRect): Integer;
{2007-06-09:
rtRectの高さを返す
}
begin
  with rtRect do begin
    Result := Bottom - Top;
  end;
end;


//汎用ルーチンここまで
//==============================================================================


//------------------------------------------------------------------------------
{MyPlayer}
constructor TMyPlayer.Create(AOwner: TComponent);
begin
  inherited;// Create(AOwner);

  if (AOwner is TWinControl) then begin
    F_hHandle := TWinControl(AOwner).Handle;
  end else begin
    F_hHandle := Application.Handle;
  end;

  F_iCmdError      := 0;
  F_iError         := 0;
  F_iDeviceID      := 0;
  F_bHasVideo      := False;
  F_rcDisplayRect  := Rect(0, 0, 0, 0);
  F_hDisplayWindow := 0;
  F_iVideoWidth    := 0;
  F_iVideoHeight   := 0;
  F_iLength        := 0;
  F_iTimeFormat    := MCI_FORMAT_MILLISECONDS;
  F_sFileName      := '';
end;

destructor TMyPlayer.Destroy;
begin
  Close;
  inherited;
end;

//開く
function TMyPlayer.Open: Boolean;
begin
  Result := Open(F_sFileName);
end;
function TMyPlayer.Open(sFile: WideString): Boolean;
var
  lr_Param:     TMCI_Open_ParmsW;
  lr_RectParam: TMCI_Anim_Rect_Parms;
  lrc_Rect: TRect;
begin
  if (F_iDeviceID <> 0) then begin
//この一連の手続きをサブルーチンにして呼び出すとエラーが起きることがある。
//ここに直接Closeの内容を書くと問題もなくいける。何故????
    F_iCmdError     := mciSendCommandW(F_iDeviceID, MCI_CLOSE, MCI_WAIT, 0);
    F_iDeviceID     := 0;
    F_bHasVideo     := False;
    F_iLength       := 0;
    F_rcDisplayRect := Rect(0, 0, 0, 0);
    F_iVideoWidth   := 0;
    F_iVideoHeight  := 0;
  end;

  F_sFileName := sFile;

  if (gfnbFileExists(F_sFileName)) then begin
    FillChar(lr_Param, SizeOf(TMCI_Open_ParmsW), 0);
    lr_Param.lpstrDeviceType  := '';  //オートセレクト
    lr_Param.lpstrElementName := PWideChar(F_sFileName);
    lr_Param.dwCallback       := 0;
    lr_Param.lpstrAlias       := '';

    F_iCmdError := mciSendCommandW(0, MCI_OPEN, MCI_WAIT or MCI_OPEN_ELEMENT {or MCI_ANIM_OPEN_NOSTATIC} {or MCI_WAVE_OPEN_BUFFER}, Longint(@lr_Param));
    Result      := (F_iCmdError = 0);
  end else begin
    Result := False;
  end;

  if (Result) then begin
    F_iDeviceID := lr_Param.wDeviceID;
    //ビデオのサイズを取得
    FillChar(lr_RectParam, SizeOf(TMCI_Anim_Rect_Parms), 0);
    F_iError        := mciSendCommandW(F_iDeviceID, MCI_WHERE, MCI_WAIT or MCI_ANIM_WHERE_SOURCE, Longint(@lr_RectParam));
    F_rcDisplayRect := lr_RectParam.rc;
    //返ってきたRectの大きさが0より大きければビデオがあるという判定
    //2007-12-26:以前は0でなければという判定をしていたのでマイナスの値でもビデオがあることになっていた
    F_bHasVideo := ((gfniRectWidth(F_rcDisplayRect) > 0) and (gfniRectHeight(F_rcDisplayRect) > 0));
    if (F_bHasVideo) then begin
      F_iVideoWidth  := gfniRectWidth (F_rcDisplayRect);
      F_iVideoHeight := gfniRectHeight(F_rcDisplayRect);
      if (F_hDisplayWindow <> 0) and (Windows.GetClientRect(F_hDisplayWindow, lrc_Rect)) then begin
        F_SetDisplayWindow(F_hDisplayWindow);  //いちいちセットしないといけない
        F_SetDisplayRect(lrc_Rect);
      end;
    end else begin
      F_rcDisplayRect := Rect(0, 0, 0, 0);
      F_iVideoWidth   := 0;
      F_iVideoHeight  := 0;
    end;
    F_iLength := F_GetMediaLength;
    F_SetTimeFormat(MCI_FORMAT_MILLISECONDS);
  end;
end;

//閉じる
function TMyPlayer.Close: Boolean;
begin
  Result := False;
  if (F_iDeviceID <> 0) then begin
    Stop;
    F_iCmdError := mciSendCommandW(F_iDeviceID, MCI_CLOSE, MCI_WAIT, 0);
    Result      := (F_iCmdError = 0);
    if (Result) then begin
      F_iDeviceID  := 0;
      F_sFileName := '';
    end;
    F_bHasVideo     := False;
    F_rcDisplayRect := Rect(0, 0, 0, 0);
    F_iVideoWidth   := 0;
    F_iVideoHeight  := 0;
//    F_hDisplayWindow := 0;  //これはコメントアウトしないといけない
    F_iLength      := 0;
  end;
end;

//Play
function TMyPlayer.Play(iPos: Longint): Boolean;
{
2018-02-02:一時停止後の再開でMIDIの音色が変わってしまうことへの暫定対処
}
var
  lr_Param: TMCI_Play_Parms;
begin
  if (F_iDeviceID <> 0)
  then begin
    FillChar(lr_Param, SizeOf(TMCI_Play_Parms), 0);
    lr_Param.dwCallback := F_hHandle; //MMNotifyイベントを送るウィンドウ
    lr_Param.dwFrom     := iPos;

    F_iCmdError := mciSendCommandW(F_iDeviceID, MCI_PLAY, MCI_NOTIFY, Longint(@lr_Param));
    Result := (F_iCmdError = 0);
  end
  else
  begin
    F_iCmdError := MCIERR_INVALID_DEVICE_NAME; //指定されたデバイスが､ オープンされていないか､ MCIに認識されていません。
    Result := False;
  end;
end;

function TMyPlayer.Resume: Boolean;
begin
  Result := Play(F_GetMediaPosition);
end;

function TMyPlayer.Play: Boolean;
{
2007-11-12:MIDIが途中で止まってしまう不具合を修正。dwFrom,dwToを設定しない。
}
var
  lr_Param: TMCI_Play_Parms;
begin
  if (F_iDeviceID <> 0) then begin
    FillChar(lr_Param, SizeOf(TMCI_Play_Parms), 0);
    lr_Param.dwCallback := F_hHandle;  //MMNotifyイベントを送るウィンドウ

    F_iCmdError := mciSendCommandW(F_iDeviceID, MCI_PLAY, MCI_NOTIFY, Longint(@lr_Param));
    Result      := (F_iCmdError = 0);
  end else begin
    F_iCmdError := MCIERR_INVALID_DEVICE_NAME;  //指定されたデバイスが､ オープンされていないか､ MCIに認識されていません。
    Result      := False;
  end;
end;

//Stop
function TMyPlayer.Stop: Boolean;
begin
  if (F_iDeviceID <> 0) then begin
    F_iCmdError := mciSendCommandW(F_iDeviceID, MCI_STOP, MCI_WAIT, 0);
    Result      := (F_iCmdError = 0);
    F_SetMediaPosition(0);
  end else begin
    F_iCmdError := MCIERR_INVALID_DEVICE_NAME;  //指定されたデバイスが､ オープンされていないか､ MCIに認識されていません。
    Result      := False;
  end;
end;

//Pause
function TMyPlayer.Pause: Boolean;
var
  li_Mode: DWORD;
begin
  if (F_iDeviceID <> 0) then begin
    li_Mode := F_GetPlayMode;
    if (li_Mode = MCI_MODE_PLAY) then begin
      //Pause
      F_iCmdError := mciSendCommandW(F_iDeviceID, MCI_PAUSE,  MCI_WAIT, 0);
    end else if (li_Mode = MCI_MODE_PAUSE) then begin
      //Resume
      //MCI_NOTIFYだと再生開始できないようだ？
//      F_iCmdError := mciSendCommandW(F_iDeviceID, MCI_RESUME, {MCI_WAIT} MCI_NOTIFY, 0);
      //Play;
      Resume;
    end;
    Result := (F_iCmdError = 0);
  end else begin
    F_iCmdError := MCIERR_INVALID_DEVICE_NAME;  //指定されたデバイスが､ オープンされていないか､ MCIに認識されていません。
    Result      := False;
  end;
{
begin
  if (F_iDeviceID <> 0) then begin
    F_iCmdError := mciSendCommandW(F_iDeviceID, MCI_PAUSE, MCI_WAIT, 0);
    Result      := (F_iCmdError = 0);
  end else begin
    F_iCmdError := MCIERR_INVALID_DEVICE_NAME;  //指定されたデバイスが､ オープンされていないか､ MCIに認識されていません。
    Result      := False;
  end;
}
end;

//巻き戻し
//Positionを頭に持っていくだけで再生はしない
function TMyPlayer.Rewind: Boolean;
begin
  if (F_iDeviceID <> 0) then begin
    F_SetMediaPosition(0);
    F_iCmdError := F_iError;
    Result      := (F_iCmdError = 0);
  end else begin
    F_iCmdError := MCIERR_INVALID_DEVICE_NAME;  //指定されたデバイスが､ オープンされていないか､ MCIに認識されていません。
    Result      := False;
  end;
end;

//巻き戻して再生
function TMyPlayer.Replay: Boolean;
begin
  Rewind;
  Result := Play;
end;

//再生状態を取得
function TMyPlayer.F_GetPlayMode: DWORD;
{
  MCI_MODE_NOT_READY  512 + 12
  MCI_MODE_STOP       512 + 13 = 525
  MCI_MODE_PLAY       512 + 14
  MCI_MODE_RECORD     512 + 15
  MCI_MODE_SEEK       512 + 16
  MCI_MODE_PAUSE      512 + 17
  MCI_MODE_OPEN       512 + 18
}
var
  lr_Param: TMCI_Status_Parms;
begin
  Result := MCI_MODE_NOT_READY;
  if (F_iDeviceID <> 0) then begin
    FillChar(lr_Param, SizeOf(TMCI_Status_Parms), 0);
    lr_Param.dwItem := MCI_STATUS_MODE;
    F_iError := mciSendCommandW(F_iDeviceID, MCI_STATUS, MCI_WAIT or MCI_STATUS_ITEM, Longint(@lr_Param));
    if (F_iError = 0) then begin
      Result := lr_Param.dwReturn;
    end;
  end;
end;

function TMyPlayer.F_GetMode: TMPModes;
begin
  case F_GetPlayMode of
    MCI_MODE_NOT_READY: Result := mpNotReady;
    MCI_MODE_STOP     : Result := mpStopped;
    MCI_MODE_PLAY     : Result := mpPlaying;
    MCI_MODE_RECORD   : Result := mpRecording;
    MCI_MODE_SEEK     : Result := mpSeeking;
    MCI_MODE_PAUSE    : Result := mpPaused;
    MCI_MODE_OPEN     : Result := mpOpen;
    else                Result := mpNotReady; //AIU
  end;
end;


//現在位置をセット
procedure TMyPlayer.F_SetMediaPosition(const iPos: Integer);
var
  lr_Param: TMCI_Seek_Parms;
begin
  if (F_iDeviceID <> 0) then begin
    lr_Param.dwTo := iPos;
    F_iError := mciSendCommandW(F_iDeviceID, MCI_SEEK, MCI_WAIT or MCI_TO, Longint(@lr_Param));
  end;
end;

//現在位置を取得
function TMyPlayer.F_GetMediaPosition: Longint;
var
  lr_Param: TMCI_Status_Parms;
begin
  Result := 0;
  if (F_iDeviceID <> 0) then begin
    FillChar(lr_Param, SizeOf(TMCI_Status_Parms), 0);
    lr_Param.dwItem := MCI_STATUS_POSITION;
    F_iError :=mciSendCommandW(F_iDeviceID, MCI_STATUS, MCI_WAIT or MCI_STATUS_ITEM, Longint(@lr_Param));
    if (F_iError = 0) then begin
      Result := lr_Param.dwReturn;
    end;
  end;
end;

//長さを取得
function TMyPlayer.F_GetMediaLength: Longint;
var
  lr_Param: TMCI_Status_Parms;
begin
  Result := 0;
  if (F_iDeviceID <> 0) then begin
    FillChar(lr_Param, SizeOf(TMCI_Status_Parms), 0);
    lr_Param.dwItem := MCI_STATUS_LENGTH;
    F_iError :=mciSendCommandW(F_iDeviceID, MCI_STATUS, MCI_WAIT or MCI_STATUS_ITEM, Longint(@lr_Param));
    if (F_iError = 0) then begin
      Result := lr_Param.dwReturn;
    end;
  end;
end;

//タイムフォーマット指定
procedure TMyPlayer.F_SetTimeFormat(const iFormat: Longint);
var
  lr_Param: TMCI_Set_Parms;
begin
  if (F_iDeviceID <> 0) then begin
    FillChar(lr_Param, SizeOf(TMCI_Set_Parms), 0);
    lr_Param.dwTimeFormat := iFormat;
    F_iError := mciSendCommandW(F_iDeviceID, MCI_SET, MCI_WAIT or MCI_SET_TIME_FORMAT, Longint(@lr_Param));
    if (F_iError = 0) then begin
      F_iTimeFormat := iFormat;
    end;
  end;
end;

{
MCI_ANIM_WINDOW_DEFAULT 結局これは0なのでわざわざ指定しなくてもと思う
}
//ビデオを表示するウィンドウの設定
procedure TMyPlayer.F_SetDisplayWindow(const hHandle: HWND);
var
  lr_Param: TMCI_Anim_Window_ParmsW;
begin
  F_hDisplayWindow := hHandle;
  if (F_iDeviceID <> 0) then begin
    FillChar(lr_Param, SizeOf(TMCI_Anim_Window_ParmsW), 0);
    lr_Param.Wnd := hHandle;
    F_iError := mciSendCommandW(F_iDeviceID, MCI_WINDOW, MCI_WAIT or MCI_ANIM_WINDOW_HWND, Longint(@lr_Param));
  end;
end;

//ビデオ描画領域のセット
procedure TMyPlayer.F_SetDisplayRect(const rcRect: TRect);
var
  lr_Param: TMCI_Anim_Rect_Parms;
begin
  if (F_iDeviceID <> 0) then begin
    FillChar(lr_Param, SizeOf(TMCI_Anim_Rect_Parms), 0);
    lr_Param.rc := rcRect;
    F_iError := mciSendCommandW(F_iDeviceID, MCI_WAIT or MCI_PUT, MCI_ANIM_RECT or MCI_ANIM_PUT_DESTINATION, Longint(@lr_Param));
    if (F_iError = 0) then begin
      F_rcDisplayRect := rcRect;
    end;
  end;
end;

//ビデオのアスペクト比
function TMyPlayer.F_GetMediaAspect: Extended;
begin
  // Width / Height なので幅から高さを出すには gfniRound(Width / gfVideoAspect)
  if (F_iVideoHeight <> 0) and (F_iVideoWidth <> 0) then begin
    Result := F_iVideoWidth / F_iVideoHeight;
  end else begin
    //ビデオなし
    Result := 1;
  end;
end;

//ビデオの表示のON/OFF
procedure TMyPlayer.F_SetVideoShow(const bShow: Boolean);
var
  lr_Param: TMCI_Anim_Window_ParmsW;
begin
  if (F_iDeviceID <> 0) then begin
    FillChar(lr_Param, SizeOf(TMCI_Anim_Window_ParmsW), 0);
    if (bShow) then begin
      lr_Param.nCmdShow := SW_SHOW;
    end else begin
      lr_Param.nCmdShow := SW_HIDE;
    end;
    F_iError := mciSendCommandW(F_iDeviceID, MCI_WINDOW, MCI_WAIT or MCI_ANIM_WINDOW_STATE, Longint(@lr_Param));
  end;
end;

function TMyPlayer.F_GetMediaAssigned: Boolean;
begin
  Result := (F_iDeviceID <> 0);
end;

function TMyPlayer.F_GetFilePath: WideString;
begin
  Result := gfnsFilePathGet(F_sFileName);
end;
function TMyPlayer.F_GetFileName: WideString;
begin
  Result := gfnsFileNameGet(F_sFileName);
end;
function TMyPlayer.F_GetFileExt: WideString;
begin
  Result := gfnsFileExtGet(F_sFileName);
end;


end.

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  StdCtrls, Grids, ExtCtrls, MMSystem, AppEvnts,
  myMPlayer;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    Button1: TButton;
    Button2: TButton;
    OpenDialog1: TOpenDialog;
    ApplicationEvents1: TApplicationEvents;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
  private
    { Private 宣言 }
    F_Player: TMyPlayer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation


{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Panel2.Align := alBottom;
  Panel1.Align := alClient;
  F_Player := TMyPlayer.Create(Self);
end;

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

procedure TForm1.FormResize(Sender: TObject);
begin
  with F_Player do begin
    if (HasVideo) then begin
      DisplayRect := Panel1.ClientRect;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if (OpenDialog1.Execute) then begin
    with F_Player do begin
      FileName := OpenDialog1.FileName;
      Open;
      if (HasVideo) then begin
        DisplayWindow := Panel1.Handle;
        //ビデオのオリジナルサイズに合わせる
        SetBounds(Left,
                  Top,
                  (Width  - ClientWidth)  + VideoWidth,
                  (Height - ClientHeight) + VideoHeight + Panel2.Height
                 );
      end;
      Play;
    end;
  end;
end;

//再生/一時停止
procedure TForm1.Button2Click(Sender: TObject);
begin
  with F_Player do begin
    //Windows APIの方の定数を使う
    if (PlayMode = MCI_MODE_PLAY) then begin
      Pause;
    end else begin
      Resume;
    end;
  end;
end;

//PlayメソッドのNotifyメッセージを受け取る
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
begin
  if (Msg.message = MM_MCINOTIFY) then begin
    with F_Player do begin
      if (Msg.wParam = MCI_NOTIFY_SUCCESSFUL) and (Position = Length) then begin
        //ループ再生
        Replay;
      end;
    end;
  end;
end;

end.