Delphi 6 ローテクTips/Unicode対応のTMediaPlayer

Unicodeファイル名に対応したTMediaPlayer。
ちょっと反則気味。

始めに

MPlayer.pasのソースコードを直接書き換えます。ということでパーソナル版だと無理なのかな。
まずはMPlayer.pasをプロジェクトのフォルダにコピーします。元のソースをいじると元に戻すのが大変なので、書き換えはコピーしたこのファイルに対して行います。
このコピーしたファイルを削除してしまえば元に戻ります。
コンポーネントのインストールはソースコードを書き換えた後でも行いません。
コンポーネントパレットのSystemのMediaPlayerをフォームに貼り付ければ、後はフォルダにコピーしたMPlayer.pasの変更が反映されます。コンパイルのときにプロジェクトフォルダのソースを優先するようなのでこれでいけます。

宣言部書き換え

TMediaPlayer = class(TCustomControl)
private
Buttons: array[TMPBtnType] of TMPButton;
FVisibleButtons: TButtonSet;
FEnabledButtons: TButtonSet;
FColoredButtons: TButtonSet;
FAutoButtons: TButtonSet;
Pressed: Boolean;
Down: Boolean;
CurrentButton: TMPBtnType;
CurrentRect: TRect;
ButtonWidth: Integer;
MinBtnSize: TPoint;
FOnClick: EMPNotify;
FOnPostClick: EMPPostNotify;
FOnNotify: TNotifyEvent;
FocusedButton: TMPBtnType;
MCIOpened: Boolean;
FCapabilities: TMPDevCapsSet;
FCanPlay: Boolean;
FCanStep: Boolean;
FCanEject: Boolean;
FCanRecord: Boolean;
FHasVideo: Boolean;
FFlags: Longint;
FWait: Boolean;
FNotify: Boolean;
FUseWait: Boolean;
FUseNotify: Boolean;
FUseFrom: Boolean;
FUseTo: Boolean;
FDeviceID: Word;
FDeviceType: TMPDeviceTypes;
FTo: Longint;
FFrom: Longint;
FFrames: Longint;
FError: Longint;
FNotifyValue: TMPNotifyValues;
FDisplay: TWinControl;
FDWidth: Integer;
FDHeight: Integer;
{*} FElementName: WideString;
FAutoEnable: Boolean;
FAutoOpen: Boolean;
FAutoRewind: Boolean;
FShareable: Boolean;

procedure LoadBitmaps;
procedure DestroyBitmaps;
procedure SetEnabledButtons(Value: TButtonSet);
procedure SetColored(Value: TButtonSet);
procedure SetVisible(Value: TButtonSet);
procedure SetAutoEnable(Value: Boolean);
procedure DrawAutoButtons;
procedure DoMouseDown(XPos, YPos: Integer);
procedure WMLButtonDown(var Message: TWMLButtonDown);
message WM_LButtonDown;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
message WM_LButtonDblClk;
procedure WMMouseMove(var Message: TWMMouseMove);
message WM_MouseMove;
procedure WMLButtonUp(var Message: TWMLButtonUp);
message WM_LButtonUp;
procedure WMSetFocus(var Message: TWMSetFocus);
message WM_SETFOCUS;
procedure WMKillFocus(var Message: TWMKillFocus);
message WM_KILLFOCUS;
procedure WMGetDlgCode(var Message: TWMGetDlgCode);
message WM_GETDLGCODE;
procedure WMSize(var Message: TWMSize);
message WM_SIZE;
function VisibleButtonCount: Integer;
procedure Adjust;
procedure DoClick(Button: TMPBtnType);
procedure DoPostClick(Button: TMPBtnType);
procedure DrawButton(Btn: TMPBtnType; X: Integer);
procedure CheckIfOpen;
procedure SetPosition(Value: Longint);
procedure SetDeviceType( Value: TMPDeviceTypes );
procedure SetWait( Flag: Boolean );
procedure SetNotify( Flag: Boolean );
procedure SetFrom( Value: Longint );
procedure SetTo( Value: Longint );
procedure SetTimeFormat( Value: TMPTimeFormats );
procedure SetDisplay( Value: TWinControl );
procedure SetOrigDisplay;
procedure SetDisplayRect( Value: TRect );
function GetDisplayRect: TRect;
procedure GetDeviceCaps;
function GetStart: Longint;
function GetLength: Longint;
function GetMode: TMPModes;
function GetTracks: Longint;
function GetPosition: Longint;
function GetErrorMessage: string;
function GetTimeFormat: TMPTimeFormats;
function GetTrackLength(TrackNum: Integer): Longint;
function GetTrackPosition(TrackNum: Integer): Longint;
protected
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure Loaded; override;
procedure AutoButtonSet(Btn: TMPBtnType); dynamic;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure Paint; override;
procedure MMNotify(var Message: TMessage); message MM_MCINOTIFY;
procedure Click(Button: TMPBtnType; var DoDefault: Boolean); reintroduce; dynamic;
procedure PostClick(Button: TMPBtnType); dynamic;
procedure DoNotify; dynamic;
procedure Updated; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Open;
procedure Close;
procedure Play;
procedure Stop;
procedure Pause; {Pause & Resume/Play}
procedure Step;
procedure Back;
procedure Previous;
procedure Next;
procedure StartRecording;
procedure Eject;
procedure Save;
procedure PauseOnly;
procedure Resume;
procedure Rewind;
property TrackLength[TrackNum: Integer]: Longint read GetTrackLength;
property TrackPosition[TrackNum: Integer]: Longint read GetTrackPosition;
property Capabilities: TMPDevCapsSet read FCapabilities;
property Error: Longint read FError;
property ErrorMessage: string read GetErrorMessage;
property Start: Longint read GetStart;
property Length: Longint read GetLength;
property Tracks: Longint read GetTracks;
property Frames: Longint read FFrames write FFrames;
property Mode: TMPModes read GetMode;
property Position: Longint read GetPosition write SetPosition;
property Wait: Boolean read FWait write SetWait;
property Notify: Boolean read FNotify write SetNotify;
property NotifyValue: TMPNotifyValues read FNotifyValue;
property StartPos: Longint read FFrom write SetFrom;
property EndPos: Longint read FTo write SetTo;
property DeviceID: Word read FDeviceID;
property TimeFormat: TMPTimeFormats read GetTimeFormat write SetTimeFormat;
property DisplayRect: TRect read GetDisplayRect write SetDisplayRect;
published
property ColoredButtons: TButtonSet read FColoredButtons write SetColored
default [btPlay, btPause, btStop, btNext, btPrev, btStep, btBack,
   btRecord, btEject];
property Enabled;
property EnabledButtons: TButtonSet read FEnabledButtons write SetEnabledButtons
default [btPlay, btPause, btStop, btNext, btPrev, btStep, btBack,
   btRecord, btEject];
property VisibleButtons: TButtonSet read FVisibleButtons write SetVisible
default [btPlay, btPause, btStop, btNext, btPrev, btStep, btBack,
   btRecord, btEject];
property Anchors;
property AutoEnable: Boolean read FAutoEnable write SetAutoEnable default True;
property AutoOpen: Boolean read FAutoOpen write FAutoOpen default False;
property AutoRewind: Boolean read FAutoRewind write FAutoRewind default True;
property Constraints;
property DeviceType: TMPDeviceTypes read FDeviceType write SetDeviceType default dtAutoSelect;
property Display: TWinControl read FDisplay write SetDisplay;
{*} property FileName: WideString read FElementName write FElementName;
property Shareable: Boolean read FShareable write FShareable default False;
property Visible;
property ParentShowHint;
property ShowHint;
property PopupMenu;
property TabOrder;
property TabStop default True;
property OnClick: EMPNotify read FOnClick write FOnClick;
property OnContextPopup;
property OnEnter;
property OnExit;
property OnPostClick: EMPPostNotify read FOnPostClick write FOnPostClick;
property OnNotify: TNotifyEvent read FOnNotify write FOnNotify;
end;

Openメソッド書き換え

procedure TMediaPlayer.Open;
const
{*} DeviceName: array[TMPDeviceTypes] of PWideChar = ('', 'AVIVideo', 'CDAudio', 'DAT',
'DigitalVideo', 'MMMovie', 'Other', 'Overlay', 'Scanner', 'Sequencer',
'VCR', 'Videodisc', 'WaveAudio');
var
{*} OpenParm: TMCI_Open_ParmsW;
DisplayR: TRect;
begin
{ zero out memory }
{*} FillChar(OpenParm, SizeOf(TMCI_Open_ParmsW), 0);
if MCIOpened then Close; {must close MCI Device first before opening another}

OpenParm.dwCallback := 0;
OpenParm.lpstrDeviceType := DeviceName[FDeviceType];
{*} OpenParm.lpstrElementName := PWideChar(FElementName);

FFlags := 0;

if FUseWait then
begin
if FWait then FFlags := mci_Wait;
FUseWait := False;
end
else
FFlags := mci_Wait;

if FUseNotify then
begin
if FNotify then FFlags := FFlags or mci_Notify;
FUseNotify := False;
end;

if FDeviceType <> dtAutoSelect then
FFlags := FFlags or mci_Open_Type;

if FDeviceType <> dtAutoSelect then
FFlags := FFlags or mci_Open_Type
else
FFlags := FFlags or MCI_OPEN_ELEMENT;

if FShareable then
FFlags := FFlags or mci_Open_Shareable;
OpenParm.dwCallback := Handle;

{*} FError := mciSendCommandW(0, mci_Open, FFlags, Longint(@OpenParm));

if FError <> 0 then {problem opening device}
raise EMCIDeviceError.Create(ErrorMessage)
else {device successfully opened}
begin
MCIOpened := True;
FDeviceID := OpenParm.wDeviceID;
FFrames := Length div 10; {default frames to step = 10% of total frames}
GetDeviceCaps; {must first get device capabilities}
if FHasVideo then {used for video output positioning}
begin
Display := FDisplay; {if one was set in design mode}
DisplayR := GetDisplayRect;
FDWidth := DisplayR.Right-DisplayR.Left;
FDHeight := DisplayR.Bottom-DisplayR.Top;
end;
if (FDeviceType = dtCDAudio) or (FDeviceType = dtVideodisc) then
TimeFormat := tfTMSF; {set timeformat to use tracks}

FAutoButtons := [btNext,btPrev]; {assumed all devices can seek to start, end}
if FCanStep then FAutoButtons := FAutoButtons + [btStep,btBack];
if FCanPlay then Include(FAutoButtons, btPlay);
if FCanRecord then Include(FAutoButtons, btRecord);
if FCanEject then Include(FAutoButtons, btEject);
if Mode = mpPlaying then AutoButtonSet(btPlay); {e.g. CD device}
DrawAutoButtons;
end;

end;

TMCI_Open_ParmsをTMCI_Open_ParmsWに、
PCharをPWideCharに、
mciSendCommandをmciSendCommandWにします。

GetDeviceCaps書き換え

上記二点だけで再生できるようになるのですが、Displayプロパティをセットした状態でUnicodeファイル名の音声メディアを読み込むと最初の一度だけエラーが出てしまいます。これを避けるためと、オリジナルでもそうなのですがメディアにビデオがあるかどうかの判定がうまくいかないので修正します。

procedure TMediaPlayer.GetDeviceCaps;
var
DevCapParm: TMCI_GetDevCaps_Parms;
devType: Longint;
RectParms: TMCI_Anim_Rect_Parms;
WorkR: TRect;
begin
FFlags := mci_Wait or mci_GetDevCaps_Item;

DevCapParm.dwItem := mci_GetDevCaps_Can_Play;
mciSendCommand(FDeviceID, mci_GetDevCaps, FFlags, Longint(@DevCapParm) );
FCanPlay := Boolean(DevCapParm.dwReturn);
if FCanPlay then Include(FCapabilities, mpCanPlay);

DevCapParm.dwItem := mci_GetDevCaps_Can_Record;
mciSendCommand(FDeviceID, mci_GetDevCaps, FFlags, Longint(@DevCapParm) );
FCanRecord := Boolean(DevCapParm.dwReturn);
if FCanRecord then Include(FCapabilities, mpCanRecord);

DevCapParm.dwItem := mci_GetDevCaps_Can_Eject;
mciSendCommand(FDeviceID, mci_GetDevCaps, FFlags, Longint(@DevCapParm) );
FCanEject := Boolean(DevCapParm.dwReturn);
if FCanEject then Include(FCapabilities, mpCanEject);
{
* DevCapParm.dwItem := mci_GetDevCaps_Has_Video;
* mciSendCommand(FDeviceID, mci_GetDevCaps, FFlags, Longint(@DevCapParm) );
* FHasVideo := Boolean(DevCapParm.dwReturn);
* if FHasVideo then Include(FCapabilities, mpUsesWindow);
}
DevCapParm.dwItem := mci_GetDevCaps_Device_Type;
mciSendCommand(FDeviceID, mci_GetDevCaps, FFlags, Longint(@DevCapParm) );
devType := DevCapParm.dwReturn;
if (devType = mci_DevType_Animation) or
   (devType = mci_DevType_Digital_Video) or
   (devType = mci_DevType_Overlay) or
   (devType = mci_DevType_VCR) then FCanStep := True;
if FCanStep then Include(FCapabilities, mpCanStep);

FFlags := mci_Anim_Where_Source;
FError := mciSendCommand( FDeviceID, mci_Where, FFlags, Longint(@RectParms) );
WorkR := RectParms.rc;
FDWidth := WorkR.Right - WorkR.Left;
FDHeight := WorkR.Bottom - WorkR.Top;
{*} FHasVideo := ((RectParms.rc.Right > 0) and (RectParms.rc.Bottom > 0));
{*} if (FHasVideo) then begin
{*} Include(FCapabilities, mpUsesWindow);
{*} end else begin
{*} Exclude(FCapabilities, mpUsesWindow);
{*} end;
end; {GetDeviceCaps}

中ほどの四行をコメントアウト、もしくは削除します。
そして終わりの六行を足します。
オリジナルだと開けるメディアは音声だけのものであってもCapabilitiesプロパティにmpUsesWindowがセットされてしまいます。
それをビデオのあるメディアの時だけmpUsesWindowをセットするようにします。

ビデオのある無しはRectを取得してRightとBottomの値が0以上ならビデオありのメディアであると判断しています。
その後ビデオがあればCapabilitiesプロパティにmpUsesWindowをセットし、なければ除外します。

GetMode書き換え

Modeを取得する場合はGetModeを書き換えなければなりません。

function TMediaPlayer.GetMode: TMPModes;
var
StatusParm: TMCI_Status_Parms;
begin
FFlags := mci_Wait or mci_Status_Item;
StatusParm.dwItem := mci_Status_Mode;
{*} FError := mciSendCommandW( FDeviceID, mci_Status, FFlags, Longint(@StatusParm));
Result := TMPModes(StatusParm.dwReturn - 524); {MCI Mode #s are 524+enum}
end;

その他

この他にも色々書き換えなければならない点があるかもしれませんしSaveメソッドも同様に書き換えなければなりません。
基本的には構造体やAPIをUnicode版のものに代えPCharをPWideCharに書き換えるなどすればOKです。
mciCommandをmciCommandWにする、など。

使用例

procedure TForm1.FormCreate(Sender: TObject);
begin
Panel2.Align := alBottom;
Panel1.Align := alClient;
MediaPlayer1.Display := Panel1;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
with MediaPlayer1 do begin
if (mpUsesWindow in Capabilities) then begin
//フォームのサイズにビデオのサイズを合わせる
DisplayRect := Panel1.ClientRect;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
ls_WFile: WideString;
begin
if (gfnbOpenFileDialog(ls_WFile)) then begin
with MediaPlayer1 do begin
FileName := ls_WFile;
Open;
if (mpUsesWindow in Capabilities) then begin
//ビデオのオリジナルサイズにフォームのサイズを合わせる
Self.SetBounds(
Self.Left,
Self.Top,
(Self.Width - Self.ClientWidth) + gfniRectWidth (DisplayRect),
(Self.Height - Self.ClientHeight) + gfniRectHeight(DisplayRect) + Panel2.Height
);
end;
Play;
end;
end;
end;

end.

ビデオのある無しはCapabilitiesプロパティにmbUsesWindowがあるかどうかで判定します。
ビデオのオリジナルサイズはOpenの直後にDisplayRectの値から出せます。