Procedure TWMAudio.SetPosition(Value: Int64);
Begin
If Not FActive Then Exit;
If Not Ahattr.FSeekable Then Exit;
Start(Value);
End;
Procedure TWMAudio.LoadFromFile(FileName: String);
Begin
LoadFromURL(FileName);
End;
Procedure TWMAudio.LoadFromURL(URL: String);
Begin
Open(URL);
End;
Procedure TWMAudio.LoadFromStream(Stream: TStream);
Begin
If m_pReader = Nil Then Exit;
ResetEvent(m_hAsyncEvent);
Close;
SetStatus(WM_OPENING);
If FStream = Nil Then
FStream := TMemoryStream.Create;
FStream.clear;
FStream.LoadFromStream(Stream);
If Failed(m_pReader2.OpenStream(GetIStream(FStream), Self, Nil)) Then
Begin
//'Could not open the Stream';
Exit;
End;
WaitForEvent(m_hAsyncEvent);
If Failed(m_hrAsync) Then
Begin
//'Could not open the specified file';
Exit;
End;
Sleep(100);
GetHeaderAttrs;
If Ahattr.FDuration = 0 Then Exit;
If Not GetAudioOutput Then Exit;
End;
Procedure TWMAudio.LoadFromResourceName(Instance: THandle; Const ResName: String; ResType: PChar);
Var
Res: TResourceStream;
Begin
Res := TResourceStream.Create(Instance, ResName, ResType);
Try
Self.LoadFromStream(Res);
Finally
Res.Free;
End;
End;
Procedure TWMAudio.LoadFromResourceID(Instance: THandle; ResID: Integer; ResType: PChar);
Var
Res: TResourceStream;
Begin
Res := TResourceStream.CreateFromID(Instance, ResID, ResType);
Try
Self.LoadFromStream(Res);
Finally
Res.Free;
End;
End;
Procedure TWMAudio.Open(FileName: String);
Begin
If Not FActive Then Exit;
If m_pReader = Nil Then Exit;
ResetEvent(m_hAsyncEvent);
Close;
SetStatus(WM_OPENING); // StringToWideChar()
m_pReader2.SetPlayMode(WMT_PLAY_MODE_AUTOSELECT);
If Failed(m_pReader.Open(PWideChar(WideString(FileName)), Self, Nil)) Then
Begin
//'Could not open the specified file';
Exit;
End;
WaitForEvent(m_hAsyncEvent);
If Failed(m_hrAsync) Then
Begin
//'Could not open the specified file';
Exit;
End;
Sleep(100);
GetHeaderAttrs;
If Ahattr.FDuration = 0 Then Exit;
If Not GetAudioOutput Then Exit;
End;
Procedure TWMAudio.Close;
Begin
If Not FActive Then Exit;
//If (FStatus = WM_STARTED) Or (FStatus = WM_PAUSED) Then
Stop;
If m_pReader <> Nil Then
If Failed(m_pReader.Close) Then
Exit;
If m_hWaveOut <> 0 Then
Begin
If waveOutReset(m_hWaveOut) <> MMSYSERR_NOERROR Then Exit;
If waveOutClose(m_hWaveOut) <> MMSYSERR_NOERROR Then Exit;
WaitForEvent(m_hAsyncEvent);
m_hWaveOut := 0;
//SetStatus(WM_CLOSED);
FreeAndNil(FStream);
End;
End;
Procedure TWMAudio.Start(Const cnsStart: Int64 = 0);
Var
mmr: MMRESULT;
Begin
If m_pReader = Nil Then Exit;
If m_hWaveOut <> 0 Then
Begin
If waveOutReset(m_hWaveOut) <> MMSYSERR_NOERROR Then Exit;
End
Else
Begin
mmr := waveOutOpen(@m_hWaveOut, WAVE_MAPPER, m_pWfx, DWORD(Addr(WaveProc)), DWORD(Self), CALLBACK_FUNCTION);
If mmr <> MMSYSERR_NOERROR Then Exit;
If hThread <> 0 Then CloseHandle(hThread);
hThread := CreateThread(Nil, 0, @OnWaveOutThread, @Self, 0, m_dwThreadID);
If hThread = 0 Then Exit;
End;
m_pReader.Start(cnsStart, 0, 1.0, Nil);
End;
Procedure TWMAudio.Play;
Begin
If Not FActive Then Exit;
Start(0);
End;
Procedure TWMAudio.Pause;
Begin
If Not FActive Then Exit;
If m_pReader = Nil Then Exit;
If m_hWaveOut <> 0 Then
Begin
If waveOutPause(m_hWaveOut) <> MMSYSERR_NOERROR Then Exit;
m_pReader.Pause;
SetStatus(WM_PAUSED);
End;
End;
Procedure TWMAudio.Resume;
Begin
If Not FActive Then Exit;
If m_pReader = Nil Then Exit;
If FStatus <> WM_PAUSED Then Exit;
If m_hWaveOut <> 0 Then
Begin
If waveOutRestart(m_hWaveOut) <> MMSYSERR_NOERROR Then Exit;
m_pReader.Resume;
SetStatus(WM_STARTED);
End;
End;
Procedure TWMAudio.Stop;
Begin
If Not FActive Then Exit;
If m_pReader = Nil Then Exit;
If (FStatus = WM_STARTED) Or (FStatus = WM_PAUSED) Then
Try
If Failed(m_pReader.Stop) Then
Exit;
Except
Exit;
End;
If m_hWaveOut <> 0 Then
Begin
If waveOutReset(m_hWaveOut) <> MMSYSERR_NOERROR Then Exit;
WaitForEvent(m_hAsyncEvent);
m_hWaveOut := 0;
CloseHandle(hThread);
hThread := 0;
End;
End;
Procedure TWMAudio.GetHeaderAttrs;
Var
Value: Pbyte;
Begin
//取歌曲标题
GetHeaderAttribute(g_wszWMTitle, Value);
If Value = Nil Then
Ahattr.FTitle := ''
Else
Begin
WideCharToStrVar(PWideChar(Value), Ahattr.FTitle);
FreeMem(Value);
End;
//取艺术家
GetHeaderAttribute(g_wszWMAuthor, Value);
If Value = Nil Then
Ahattr.FAuthor := ''
Else
Begin
WideCharToStrVar(PWideChar(Value), Ahattr.FAuthor);
FreeMem(Value);
End;
//取版权
GetHeaderAttribute(g_wszWMCopyright, Value);
If Value = Nil Then
Ahattr.FCopyright := ''
Else
Begin
WideCharToStrVar(PWideChar(Value), Ahattr.FCopyright);
FreeMem(Value);
End;
{$IFDEF BYCOPYRIGHT}
Ahattr.FCopyright = ByCopyRight;
{$ENDIF}
//取注释
GetHeaderAttribute(g_wszWMDescription, Value);
If Value = Nil Then
Ahattr.FDescription := ''
Else
Begin
WideCharToStrVar(PWideChar(Value), Ahattr.FDescription);
FreeMem(Value);
End;
//取长度
GetHeaderAttribute(g_wszWMDuration, Value);
If Value = Nil Then
Ahattr.FDuration := 0
Else
Begin
Ahattr.FDuration := Int64(PPointerArray(Value)[0]);
FreeMem(Value);
End;
SetTime(0, Ahattr.FDuration);
//是否允许快进
GetHeaderAttribute(g_wszWMSeekable, Value);
If Value = Nil Then
Ahattr.FSeekable := false
Else
Begin
Ahattr.FSeekable := Boolean(PPointerArray(Value)[0]);
FreeMem(Value);
End;
// GetHeaderAttribute(g_wszWMBroadcast, Value);
// If Value = Nil Then
// m_bIsBroadcast := FALSE
// Else
// Begin
// m_bIsBroadcast := Boolean(Value);
// FreeMem(Value);
// End;
End;
Procedure TWMAudio.GetHeaderAttribute(Name: WideString; Var Value: Pbyte);
Var
StreamNum: Word;
wmtType: WMT_ATTR_DATATYPE;
Len: Word;
hr: HRESULT;
v: Pbyte;
Begin
If m_pHeaderInfo = Nil Then Exit;
StreamNum := 0;
Len := 0;
Value := Nil;
hr := m_pHeaderInfo.GetAttributeByName(StreamNum, PWideChar(Name), wmtType, Nil, Len);
If Failed(hr) Then Exit;
If hr = ASF_E_NOTFOUND Then Exit;
GetMem(v, Len);
If v = Nil Then Exit;
hr := m_pHeaderInfo.GetAttributeByName(StreamNum, PWideChar(Name), wmtType, v, Len);
If Failed(hr) Then Exit;
Value := v;
End;
Function TWMAudio.GetIStream(Stream: TStream): IStream;
Var
Adapt: TStreamAdapter;
tPos: Int64;
Begin
Adapt := TStreamAdapter.Create(FStream);
Adapt.Seek(0, 0, tPos);
Result := Adapt As IStream;
End;
Procedure TWMAudio.SetTime(TimeElapsed, FileDuration: Int64);
Function GetTimeText(Value: Int64): String;
Var
dwSeconds, nHours, nMins: Word;
Begin
dwSeconds := 0;
nHours := 0;
nMins := 0;
dwSeconds := Value Div 10000000;
nHours := dwSeconds Div 60 Div 60;
dwSeconds := dwSeconds Mod 3600;
nMins := dwSeconds Div 60;
dwSeconds := dwSeconds Mod 60;
If nHours <> 0 Then
Result := Format('%d:', [nHours]);
Result := Result + Format('%.2d:%.2d', [nMins, dwSeconds]);
End;
Var
ElapsedText, RemainingText, DurationText: String;
Begin
FPosition := TimeElapsed;
Ahattr.FDuration := FileDuration;
{$IFDEF TRIAL}
If TimeElapsed >= (FileDuration Div 2) Then
Begin
End;
{$ENDIF}
If Not Assigned(FOnPositionChange) Then Exit;
Destructor TWMAudio.Destroy;
Begin
SetActive(false);
Ahattr.Free;
Inherited;
End;
Procedure TWMAudio.SetActive(Value: Boolean);
Begin
If FActive = Value Then Exit;
Case Value Of
true:
Begin
m_hAsyncEvent := CreateEvent(Nil, false, false, Nil);
If m_hAsyncEvent = INVALID_HANDLE_VALUE Then
Begin
//'Could not create the event';
Exit;
End;
If Failed(WMCreateReader(Nil, WMT_RIGHT_PLAYBACK, m_pReader)) Then
Begin
//'Could not create Reader';
Exit;
End;
If Failed(m_pReader.QueryInterface(IID_IWMReaderAdvanced2, m_pReader2)) Then
Begin
//'Could not QI for IWMReaderAdvanced2';
Exit;
End;
If Failed(m_pReader.QueryInterface(IID_IWMHeaderInfo, m_pHeaderInfo)) Then
Begin
//'Could not QI for IWMHeaderInfo';
Exit;
End;
FActive := true;
End;
false:
Begin
Close;
m_pHeaderInfo := Nil;
m_pReader2 := Nil;
m_pReader := Nil;
If hThread <> 0 Then
Begin
CloseHandle(hThread);
hThread := 0;
End;
If m_hWaveOut <> 0 Then
Begin
waveOutClose(m_hWaveOut);
m_hWaveOut := 0;
End;
If m_hAsyncEvent <> 0 Then
Begin
CloseHandle(m_hAsyncEvent);
m_hAsyncEvent := 0;
End;
If m_pWfx <> Nil Then
Begin
FreeMem(m_pWfx);
m_pWfx := Nil;
End;
If FStream <> Nil Then
FreeAndNil(FStream);
FActive := false;
End;
End;
Function TWMAudio.QueryInterface(Const IID: TGUID;
Out Obj): Integer;
Begin
If GetInterface(IID, Obj) Then Result := S_OK
Else Result := E_NOINTERFACE;
End;
Function TWMAudio._AddRef: Integer;
Begin
Inc(FRefCount);
Result := FRefCount;
End;
Function TWMAudio._Release: Integer;
Begin
Dec(FRefCount);
Result := FRefCount;
End;
Function TWMAudio.OnSample(dwOutputNum: LongWord; cnsSampleTime, cnsSampleDuration: Int64;
dwFlags: LongWord; pSample: INSSBuffer; pvContext: Pointer): HRESULT;
Var
hr: HRESULT;
mmr: MMRESULT;
cbData: LongWord;
pData: Pbyte;
m_pWh: PWaveHdr;
Begin
If m_dwAudioOutputNum <> dwOutputNum Then
Begin
Result := S_OK;
Exit;
End;
hr := S_OK;
cbData := 0;
pData := Nil;
hr := pSample.GetBufferAndLength(pData, cbData);
If Failed(hr) Then
Begin
Result := hr;
Exit;
End;
GetMem(m_pWh, SizeOf(WAVEHDR) + cbData);
GetMem(m_pWh^.lpData, cbData);
m_pWh^.dwBufferLength := cbData;
m_pWh^.dwBytesRecorded := cbData;
m_pWh^.dwUser := cnsSampleTime;
m_pWh^.dwLoops := 0;
m_pWh^.dwFlags := 0;
m_pWh^.lpNext := Nil;
m_pWh^.reserved := 0;
CopyMemory(m_pWh^.lpData, pData, cbData);
While true Do
Begin
mmr := waveOutPrepareHeader(m_hWaveOut, m_pWh, SizeOf(WAVEHDR));
If mmr <> MMSYSERR_NOERROR Then Break;
hr := waveOutWrite(m_hWaveOut, m_pWh, SizeOf(WAVEHDR));
If hr <> MMSYSERR_NOERROR Then Break;
SetTime(cnsSampleTime, Ahattr.FDuration);
End;
pData := Nil;
If mmr <> MMSYSERR_NOERROR Then
Begin
Try
If m_pWh <> Nil Then
Begin
FreeMem(m_pWh^.lpData);
FreeMem(m_pWh);
m_pWh := Nil;
End;
Except
End;
Stop;
End;
Result := S_OK;
End;
Function TWMAudio.OnStatus(Status: TWMTStatus; hr: HRESULT; dwType: TWMTAttrDataType;
pValue: Pbyte; pvContext: Pointer): HRESULT;
Begin
Case Status Of
WMT_ERROR:
Begin
SetStatus(WM_ERROR);
SetAsyncEvent(hr);
End;
WMT_OPENED: {打开}
Begin
SetStatus(WM_OPENED);
SetAsyncEvent(0);
End;
WMT_STARTED: SetStatus(WM_STARTED); {播放}
WMT_CLOSED: {关闭}
Begin
SetStatus(WM_CLOSED);
SetAsyncEvent(0);
End;
WMT_STOPPED: {停止}
Begin
SetStatus(WM_STOPED);
SetAsyncEvent(0);
End;
Procedure TWMAudio.SetStatus(Status: TWM_Status);
Begin
FStatus := Status;
FStatusText := WM_StatusText[FStatus];
If Not Assigned(FOnStatus) Then Exit;
FOnStatus(Self, Status, FStatusText);
End;
Procedure WaveProc(hwo: HWAVEOUT; uMsg: Uint; DwInstance, DwParam1, DwParam2: DWORD); Stdcall;
Var
P: Pointer;
Begin
P := Pointer(DwInstance);
PostThreadMessage(TWMAudio(P).m_dwThreadID, uMsg, DwParam1, DwParam2);
End;
Function OnWaveOutThread(lpParameter: Pointer): LongInt; Stdcall;
Begin
TWMAudio(lpParameter).OnWaveOutMsg;
Result := 0;
End;
Procedure TWMAudio.OnWaveOutMsg;
Var
Msg: TMsg;
pwh: PWaveHdr;
mmr: MMRESULT;
Begin
pwh := Nil;
mmr := MMSYSERR_NOERROR;
PeekMessage(Msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
While GetMessage(Msg, 0, 0, 0) Do
Begin
Case Msg.message Of
MM_WOM_DONE:
Begin
pwh := PWaveHdr(Msg.wParam);
mmr := waveOutUnprepareHeader(m_hWaveOut, pwh, SizeOf(TWaveHdr));
Try
FreeMem(pwh^.lpData);
FreeMem(pwh);
pwh := Nil;
Except
End;
If mmr = MMSYSERR_NOERROR Then
Else If mmr = WHDR_ENDLOOP Then
SetEvent(m_hAsyncEvent)
//Else If mmr = MMSYSERR_INVALHANDLE Then
// SetEvent(m_hAsyncEvent)
//Else Stop;
End;
WOM_CLOSE: PostQuitMessage(0);
End;
End;
End;
Procedure TWMAudio.SetAsyncEvent(hrAsync: HRESULT);
Begin
m_hrAsync := hrAsync;
SetEvent(m_hAsyncEvent);
End;
Procedure TWMAudio.WaitForEvent(hEvent: THandle; Const msMaxWaitTime: DWORD);
Var
i: DWORD;
Msg: TMsg;
Begin
i := 0;
While i < msMaxWaitTime Do
Begin
If PeekMessage(Msg, 0, 0, 0, PM_REMOVE) Then
Begin
TranslateMessage(Msg);
DispatchMessage(Msg);
End;
If WaitForSingleObject(hEvent, 10) <> WAIT_TIMEOUT Then Break;
Inc(i, 10);
End;
End;
Function TWMAudio.GetAudioOutput: Boolean;
Var
cOutputs, cbType, i: LongWord;
pMediaType: PWMMediaType;
pProps: IWMOutputMediaProps;
Begin
Result := false;
cOutputs := 0;
cbType := 0;
pMediaType := Nil;
If m_pReader = Nil Then Exit;
If Failed(m_pReader.GetOutputCount(cOutputs)) Then
Begin
//'Could not get output count';
Exit;
End;
For i := 0 To cOutputs - 1 Do
Begin
pProps := Nil;
If pMediaType <> Nil Then
Begin
FreeMem(pMediaType);
pMediaType := Nil;
End;
If Failed(m_pReader.GetOutputProps(i, pProps)) Then
Begin
//'Could not get output props';
Exit;
End;
If Failed(pProps.GetMediaType(Nil, cbType)) Then
Begin
//'Could not query for the space needed for media type';
pProps := Nil;
Exit;
End;
GetMem(pMediaType, cbType);
If Failed(pProps.GetMediaType(pMediaType, cbType)) Then
Begin
//'Could not get media type';
pProps := Nil;
Exit;
End;
If IsEqualGUID(pMediaType^.majortype, WMMEDIATYPE_Audio) Then
Break;
End;
If cOutputs = i Then
Begin
//'Could not find an audio stream in the specified file';
Exit;
End;
m_dwAudioOutputNum := i;
If m_pWfx <> Nil Then
Begin
FreeMem(m_pWfx);
m_pWfx := Nil;
End;
GetMem(m_pWfx, pMediaType^.cbFormat);
CopyMemory(m_pWfx, pMediaType^.pbFormat, pMediaType^.cbFormat);
If pMediaType <> Nil Then
Begin
FreeMem(pMediaType);
pMediaType := Nil;
End;
pProps := Nil;
Result := true;
End;
Const
WM_StatusText: Array[TWM_Status] Of String = (
'An error occurred in reading the file.',
'The file has been opening for reading.',
'The file has been opened for reading.',
'The reader has started reading the file.',
'The reader has paused reading the file.',
'The reader has stoped reading the file.',
'The reader has closed the file.',
'The reader has started buffering data.',
'The reader has stoped buffering data.',
'The reader has reached the end of the file.',
'The end of a segment has been encountered.',
'The file has finished streaming.',
'The reader object has begun saving a file from a server.',
'The reader has stopped saving a file from a server.',
'The reader is locating a server.',
'The reader is connecting to a server.',
'The reader has tried to play back DRM version 1 content and the computer does not have an appropriate license to play it.',
'The reader has tried to play back DRM version 7 content and the computer does not have an appropriate license to play it.',
'The client needs a security update.',
'The reader does not have the appropriate codec to decompress this file.',
'The license acquisition process is complete.',
'The individualization process is in progress or has completed.',
'The metadata has changed for the current source.',
'There has been a change to the settings for the current source.',
'There has been a change in source file or stream.');
Type
TOnPositionChange = Procedure(Sender: TObject; lPos, lLen: Int64; ElapsedText, RemainingText, DurationText: String) Of Object;
TOnStatus = Procedure(Sender: TObject; Status: TWM_Status; StatusText: String) Of Object;