unit Unit1;interfaceusesWinapi.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;constCLASS_Player: TGUID = '{A9332148-C691-4B9D-91FC-B9C461DBE9DD}';typePIUnknown = ^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;varfrmMain: TfrmMain;implementation{$R *.dfm}{ TForm1 }procedure TfrmMain.btnOpenClick(Sender: TObject);
beginif not APlayerCreateSuccess then Exit;if dlgOpen1.Execute(Handle) thenbeginAPlayer.Open(dlgOpen1.FileName);end;
end;procedure TfrmMain.btnPathClick(Sender: TObject);
beginif not APlayerCreateSuccess then Exit;ShowMessage(APlayer.GetConfig(2));
end;function TfrmMain.CreateComObjectFromDll(CLSID: TGUID;DllHandle: THandle): IUnknown;
varFactory: IClassFactory;DllGetClassObject: function(const CLSID, IID: TGUID; var Obj): HResult; stdcall;hr: HRESULT;
beginDllGetClassObject := GetProcAddress(DllHandle, 'DllGetClassObject');if Assigned(DllGetClassObject) thenbeginhr := DllGetClassObject(CLSID, IClassFactory, Factory);if hr = S_OK thentryhr := Factory.CreateInstance(nil, IUnknown, Result);if hr <> S_OK thenbeginMessageBox(Handle, '创建APlayer实例失败！', '错误', MB_OK + MB_ICONERROR);end;exceptMessageBox(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);
varov: 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:beginend;// function OnStateChanged(nOldState: Integer; nNewState: Integer): HResult; dispid 2;$00000002:beginend;// function OnOpenSucceeded: HResult; dispid 3;$00000003:beginend;// function OnSeekCompleted(nPosition: Integer): HResult; dispid 4;$00000004:beginend;// function OnBuffer(nPercent: Integer): HResult; dispid 5;$00000005:beginend;// function OnVideoSizeChanged: HResult; dispid 6;$00000006:beginend;// function OnDownloadCodec(const strCodecPath: WideString): HResult; dispid 7;$00000007:beginov := OleVariant(Params.rgvarg[0]);MessageBox(Handle, PChar('缺少解码器文件：' + VarToStr(ov)), '错误', MB_OK + MB_ICONERROR);end;// function OnEvent(nEventCode: Integer; nEventParam: Integer): HResult; dispid 8;$00000008:beginend;end
end;procedure TfrmMain.FormCreate(Sender: TObject);
beginReportMemoryLeaksOnShutdown := DebugHook <> 0;APlayerCreateSuccess := InitAPlayer;
end;function TfrmMain.InitAPlayer: Boolean;
varhModule, hDll: THandle;AtlAxAttachControl: TAtlAxAttachControl;
beginhModule := LoadLibrary('atl.dll');if hModule < 32 thenbeginExit(False);end;AtlAxAttachControl := TAtlAxAttachControl(GetProcAddress(hModule, 'AtlAxAttachControl'));EventSink := TEventSink.Create(Self);EventSink.OnInvoke := EventSinkInvoke;if not Assigned(AtlAxAttachControl) thenExit(False);tryhDll := LoadLibrary('APlayer.dll');APlayer := CreateComObjectFromDll(CLASS_Player, hDll) as IDispatch;if VarIsNull(APlayer) thenbeginExit(False);end;EventSink.Connect(APlayer, _IPlayerEvents);AtlAxAttachControl(APlayer, pnlCom.Handle, nil);Result := True;exceptResult := False;end;
end;end.

unit EventSink;interfaceusesWinapi.Windows, Winapi.Messages, System.SysUtils, System.Classes,Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,Winapi.ActiveX;typeTInvokeEvent = 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)privateFDispatch: 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;publicconstructor 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;implementationusesComObj;procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;const Sink: IUnknown; var Connection: LongInt);
varCPC: IConnectionPointContainer;CP: IConnectionPoint;i: HRESULT;
beginConnection := 0;if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) thenif Succeeded(CPC.FindConnectionPoint(IID, CP)) theni := CP.Advise(Sink, Connection);
end;procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;var Connection: LongInt);
varCPC: IConnectionPointContainer;CP: IConnectionPoint;
beginif Connection <> 0 thenif Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) thenif Succeeded(CPC.FindConnectionPoint(IID, CP)) thenif Succeeded(CP.Unadvise(Connection)) thenConnection := 0;
end;{ TAbstractEventSink }function TAbstractEventSink._AddRef: Integer; stdcall;
beginResult := 2;
end;function TAbstractEventSink._Release: Integer; stdcall;
beginResult := 1;
end;constructor TAbstractEventSink.Create(AOwner: TComponent);
begininherited Create;FOwner := AOwner;
end;destructor TAbstractEventSink.Destroy;
varp: Pointer;
beginDisconnect;inherited Destroy;
end;function TAbstractEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
beginResult := E_NOTIMPL;
end;function TAbstractEventSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT; stdcall;
beginResult := E_NOTIMPL;
end;function TAbstractEventSink.GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
beginCount := 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 forResult := E_NOINTERFACE;if GetInterface(IID, Obj) thenResult := S_OK;if IsEqualGUID(IID, FDispIntfIID) and GetInterface(IDispatch, Obj) thenResult := S_OK;
end;procedure TAbstractEventSink.Connect(AnAppDispatch: IDispatch;const AnAppDispIntfIID: TGUID);
beginFDispIntfIID := AnAppDispIntfIID;FDispatch := AnAppDispatch;// Hook the sink up to the automation serverInterfaceConnect(FDispatch, FDispIntfIID, Self, FConnection);
end;procedure TAbstractEventSink.Disconnect;
beginif Assigned(FDispatch) thenbegin// Unhook the sink from the automation serverInterfaceDisconnect(FDispatch, FDispIntfIID, FConnection);FDispatch := nil;FConnection := 0;end;
end;{ TEventSink }procedure TEventSink.Connect(AnAppDispatch: IDispatch;const AnAppDispIntfIID: TGUID);
beginFSink.Connect(AnAppDispatch, AnAppDispIntfIID);
end;constructor TEventSink.Create(AOwner: TComponent);
begininherited Create(AOwner);FSink := TAbstractEventSink.Create(Self);
end;destructor TEventSink.Destroy;
beginFSink.Free;inherited Destroy;
end;procedure TEventSink.DoInvoke(DispID: Integer; const IID: TGUID;LocaleID: Integer; Flags: Word; var Params;VarResult, ExcepInfo, ArgErr: Pointer);
beginif Assigned(FOnInvoke) thenFOnInvoke(Self, DispID, IID, LocaleID, Flags, TDispParams(Params),VarResult, ExcepInfo, ArgErr);
end;end.