在Delphi下使用迅雷APlayer组件进行免注册开发

之前都是用的delphi下的dspack进行的视频开发，这个组件其实很好用，就是找解码器麻烦点，而且还得在客户的计算机上使用RegSvr32.exe也注册解码器，要不有可能播放不了。

结果在查找合适的解码器过程中，无意搜索到了迅雷的APlayer组件。

迅雷APlayer这个组件提供了一个完整的解码器合集（核心的流媒体播放技术也是DirectShow和dspack一样一样的），下载APlayer的解码器合集并注册到系统后，确实在dspack也用的挺好，不过看了APlayer的介绍后发现人家做的更好，虽然是个ActiveX，但是给出的c++示例表示无需显式注册即可使用（就是不需要用Regsvr32.exe预先注册APlayer组件到目标计算机上），而且也无需预先注册解码器（也是Regsvr32）到操作系统，只要指定解码器路径，APlayer可以自行搜索此路径查找合适的解码器，简直太好了，本来就怕发布到客户计算机上后由于解码器问题导致播放不正常（其实开发测试阶段已经出现过了），这么个好东西赶快试试。

第一次使用先按照Delphi下的传统方式来，在开发环境中引入APlayer组件，这个就是个ActiveX控件，添加到组件面板上，建个工程拖到窗体上，响应几个事件，轻轻松松视频就开始播放了，呵呵，也不用关心解码器文件缺不缺了，APlayer组件会查找并指示出来缺少的文件，真是太智能了，省心，好用。

接下来晋级操作，怎么不注册APlayer.dll就能直接创建ActiveX组件在自己的程序里面呢？看APlayer的示例工程定义了两个函数（BOOL CreateAPlayerFromFile(void)、HRESULT CreateInstanceFromFile(const TCHAR * pcszPath, REFCLSID rclsid, REFIID riid, IUnknown * pUnkOuter, LPVOID * ppv)），直接通过APlayer.dll就创建了ActiveX组件，不过那个示例工程是C++的，咱们不熟，对照着改了下，没搞定，于是求助万能的网络搜索引擎，目标：Delphi不注册COM直接使用ActiveX控件并绑定事件，呵呵，感谢前辈们，果然有啊，原文章链接：http://blog.csdn.net/love3s/article/details/7411757

照着来吧，按照这位前辈的话，文笔不好直接上代码吧：

unit Unit1;

interface

uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.OleCtnrs, System.Win.ComObj, EventSink, Winapi.ActiveX,
Vcl.ExtCtrls, Vcl.StdCtrls;

const
CLASS_Player: TGUID = '{A9332148-C691-4B9D-91FC-B9C461DBE9DD}';

type
PIUnknown = ^IUnknown;
TAtlAxAttachControl = function(Control: IUnknown; hwind: hwnd; ppUnkContainer: PIUnknown): HRESULT; stdcall;

_IPlayerEvents = dispinterface
['{31D6469C-1DA7-47C0-91F9-38F0C39F9B89}']
{
function OnMessage(nMessage: Integer; wParam: Integer; lParam: Integer): HResult; dispid 1;
function OnStateChanged(nOldState: Integer; nNewState: Integer): HResult; dispid 2;
function OnOpenSucceeded: HResult; dispid 3;
function OnSeekCompleted(nPosition: Integer): HResult; dispid 4;
function OnBuffer(nPercent: Integer): HResult; dispid 5;
function OnVideoSizeChanged: HResult; dispid 6;
function OnDownloadCodec(const strCodecPath: WideString): HResult; dispid 7;
function OnEvent(nEventCode: Integer; nEventParam: Integer): HResult; dispid 8;
}
end;

TfrmMain = class(TForm)
pnlCom: TPanel;
btnOpen: TButton;
dlgOpen1: TOpenDialog;
btnPath: TButton;
procedure FormCreate(Sender: TObject);
procedure btnOpenClick(Sender: TObject);
procedure btnPathClick(Sender: TObject);
private
{ Private declarations }
APlayer: Variant;
APlayerCreateSuccess: Boolean;
EventSink: TEventSink;
function InitAPlayer: Boolean;
function CreateComObjectFromDll(CLSID: TGUID; DllHandle: THandle): IUnknown;
procedure EventSinkInvoke(Sender: TObject; DispID: Integer;
const IID: TGUID; LocaleID: Integer; Flags: Word;
Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr: Pointer);
public
{ Public declarations }
end;

var
frmMain: TfrmMain;

implementation

{$R *.dfm}

{ TForm1 }

procedure TfrmMain.btnOpenClick(Sender: TObject);
begin
if not APlayerCreateSuccess then Exit;

if dlgOpen1.Execute(Handle) then
begin
APlayer.Open(dlgOpen1.FileName);
end;
end;

procedure TfrmMain.btnPathClick(Sender: TObject);
begin
if not APlayerCreateSuccess then Exit;
ShowMessage(APlayer.GetConfig(2));
end;

function TfrmMain.CreateComObjectFromDll(CLSID: TGUID;
DllHandle: THandle): IUnknown;
var
Factory: IClassFactory;
DllGetClassObject: function(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
hr: HRESULT;
begin
DllGetClassObject := GetProcAddress(DllHandle, 'DllGetClassObject');
if Assigned(DllGetClassObject) then
begin
hr := DllGetClassObject(CLSID, IClassFactory, Factory);
if hr = S_OK then
try
hr := Factory.CreateInstance(nil, IUnknown, Result);
if hr <> S_OK then
begin
MessageBox(Handle, '创建APlayer实例失败！', '错误', MB_OK + MB_ICONERROR);
end;
except
MessageBox(Handle, PChar('创建APlayer实例失败！错误代码：' + IntToStr(GetLastError)), '错误', MB_OK + MB_ICONERROR);
end;
end;
end;

procedure TfrmMain.EventSinkInvoke(Sender: TObject; DispID: Integer;
const IID: TGUID; LocaleID: Integer; Flags: Word; Params: tagDISPPARAMS;
VarResult, ExcepInfo, ArgErr: Pointer);
var
ov: OleVariant;
begin
{
这里需要注明Params这个参数, 包含了事件的参数
如：
Params.rgvarg[0] 代表第一个参数
Params.rgvarg[1] 代表第二个参数
......
Params.rgvarg[65535] 代表第65535个参数
最多65535个参数
具体可以参考 tagDISPPARAMS 的定义
}
case dispid of
// function OnMessage(nMessage: Integer; wParam: Integer; lParam: Integer): HResult; dispid 1;
$00000001:
begin

end;
// function OnStateChanged(nOldState: Integer; nNewState: Integer): HResult; dispid 2;
$00000002:
begin

end;
// function OnOpenSucceeded: HResult; dispid 3;
$00000003:
begin

end;
// function OnSeekCompleted(nPosition: Integer): HResult; dispid 4;
$00000004:
begin

end;
// function OnBuffer(nPercent: Integer): HResult; dispid 5;
$00000005:
begin

end;
// function OnVideoSizeChanged: HResult; dispid 6;
$00000006:
begin

end;
// function OnDownloadCodec(const strCodecPath: WideString): HResult; dispid 7;
$00000007:
begin
ov := OleVariant(Params.rgvarg[0]);
MessageBox(Handle, PChar('缺少解码器文件：' + VarToStr(ov)), '错误', MB_OK + MB_ICONERROR);
end;
// function OnEvent(nEventCode: Integer; nEventParam: Integer): HResult; dispid 8;
$00000008:
begin

end;
end
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
ReportMemoryLeaksOnShutdown := DebugHook <> 0;
APlayerCreateSuccess := InitAPlayer;
end;

function TfrmMain.InitAPlayer: Boolean;
var
hModule, hDll: THandle;
AtlAxAttachControl: TAtlAxAttachControl;
begin
hModule := LoadLibrary('atl.dll');
if hModule < 32 then
begin
Exit(False);
end;
AtlAxAttachControl := TAtlAxAttachControl(GetProcAddress(hModule, 'AtlAxAttachControl'));
EventSink := TEventSink.Create(Self);
EventSink.OnInvoke := EventSinkInvoke;
if not Assigned(AtlAxAttachControl) then
Exit(False);
try
hDll := LoadLibrary('APlayer.dll');
APlayer := CreateComObjectFromDll(CLASS_Player, hDll) as IDispatch;
if VarIsNull(APlayer) then
begin
Exit(False);
end;
EventSink.Connect(APlayer, _IPlayerEvents);
AtlAxAttachControl(APlayer, pnlCom.Handle, nil);

Result := True;
except
Result := False;
end;
end;

end.

接下来EventSink单元代码（绑定ActiveX控件事件用的）：

unit EventSink;

interface

uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Winapi.ActiveX;

type
TInvokeEvent = procedure(Sender: TObject; DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; Params: TDispParams;
VarResult, ExcepInfo, ArgErr: Pointer) of object;

TAbstractEventSink = class(TObject, IUnknown, IDispatch)
private
FDispatch: IDispatch;
FDispIntfIID: TGUID;
FConnection: LongInt;
FOwner: TComponent;
protected
{ IUnknown }
function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
{ IDispatch }
function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo)
: HRESULT; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer)
: HRESULT; stdcall;
public
constructor Create(AOwner: TComponent);
destructor Destroy; override;
procedure Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID);
procedure Disconnect;
end;

TEventSink = class(TComponent)
private
{ Private declarations }
FSink: TAbstractEventSink;
FOnInvoke: TInvokeEvent;
protected
{ Protected declarations }
procedure DoInvoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer); virtual;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID);
published
{ Published declarations }
property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke;
end;

implementation

uses
ComObj;

procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
const Sink: IUnknown; var Connection: LongInt);
var
CPC: IConnectionPointContainer;
CP: IConnectionPoint;
i: HRESULT;
begin
Connection := 0;
if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
i := CP.Advise(Sink, Connection);
end;

procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
var Connection: LongInt);
var
CPC: IConnectionPointContainer;
CP: IConnectionPoint;
begin
if Connection <> 0 then
if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
if Succeeded(CP.Unadvise(Connection)) then
Connection := 0;
end;

{ TAbstractEventSink }

function TAbstractEventSink._AddRef: Integer; stdcall;
begin
Result := 2;
end;

function TAbstractEventSink._Release: Integer; stdcall;
begin
Result := 1;
end;

constructor TAbstractEventSink.Create(AOwner: TComponent);
begin
inherited Create;
FOwner := AOwner;
end;

destructor TAbstractEventSink.Destroy;
var
p: Pointer;
begin
Disconnect;

inherited Destroy;
end;

function TAbstractEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
begin
Result := E_NOTIMPL;
end;

function TAbstractEventSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo)
: HRESULT; stdcall;
begin
Result := E_NOTIMPL;
end;

function TAbstractEventSink.GetTypeInfoCount(out Count: Integer)
: HRESULT; stdcall;
begin
Count := 0;
Result := S_OK;
end;

function TAbstractEventSink.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params;
VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; stdcall;
begin
(FOwner as TEventSink).DoInvoke(DispID, IID, LocaleID, Flags, Params,
VarResult, ExcepInfo, ArgErr);
Result := S_OK;
end;

function TAbstractEventSink.QueryInterface(const IID: TGUID; out Obj)
: HRESULT; stdcall;
begin
// We need to return the event interface when it's asked for
Result := E_NOINTERFACE;
if GetInterface(IID, Obj) then
Result := S_OK;
if IsEqualGUID(IID, FDispIntfIID) and GetInterface(IDispatch, Obj) then
Result := S_OK;
end;

procedure TAbstractEventSink.Connect(AnAppDispatch: IDispatch;
const AnAppDispIntfIID: TGUID);
begin
FDispIntfIID := AnAppDispIntfIID;
FDispatch := AnAppDispatch;
// Hook the sink up to the automation server
InterfaceConnect(FDispatch, FDispIntfIID, Self, FConnection);
end;

procedure TAbstractEventSink.Disconnect;
begin
if Assigned(FDispatch) then
begin
// Unhook the sink from the automation server
InterfaceDisconnect(FDispatch, FDispIntfIID, FConnection);
FDispatch := nil;
FConnection := 0;
end;
end;

{ TEventSink }

procedure TEventSink.Connect(AnAppDispatch: IDispatch;
const AnAppDispIntfIID: TGUID);
begin
FSink.Connect(AnAppDispatch, AnAppDispIntfIID);
end;

constructor TEventSink.Create(AOwner: TComponent);
begin
inherited Create(AOwner);

FSink := TAbstractEventSink.Create(Self);
end;

destructor TEventSink.Destroy;
begin
FSink.Free;

inherited Destroy;
end;

procedure TEventSink.DoInvoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params;
VarResult, ExcepInfo, ArgErr: Pointer);
begin
if Assigned(FOnInvoke) then
FOnInvoke(Self, DispID, IID, LocaleID, Flags, TDispParams(Params),
VarResult, ExcepInfo, ArgErr);
end;

end.

循着前辈的脚步果然很容易并顺利的解决了问题，我在APlayer论坛看有人问怎么在Delphi下也可以免注册使用APlayer组件呢，呵呵，现在有答案了！而且我们掌握了一个重要的Delphi技能“Delphi不注册COM直接使用ActiveX控件并绑定事件”，开心！特此记录。

后附程序执行的截图：

1、程序设计界面，只是放置了两个按钮、一个OpenDialog、一个Panel（作为APlayer组件的容器）。



2、程序运行后，可以看到APlayer组件成功创建到了Panel上，读取APlayer的解码器路径，和APlayer.dll在同一目录下，如果用的注册ActiveX的方式并拖拽到窗体上进行开发的，自己试试就会发现解码器路径固定在“C:\Users\Public\Thunder Network\APlayer”且无法修改。如果解码器路径固定了会导致在客户端计算机部署时更复杂些，不如在本地目录方便，况且还得在客户计算机上注册APlayer组件，忒麻烦了。呵呵，免注册真好！



3、播放