mmwavout.pas

一套及时通讯的原码

{ Allocate memory for the WaveOut header and buffer }
procedure TMMWaveOut.AllocWaveHeader(var lpWaveHdr: PWaveHdr);
begin
   if (lpWaveHdr = Nil) then
   begin
      { set up a wave header for playing and lock. }
      lpWaveHdr := FAllocator.AllocBuffer(GPTR, SizeOf(TMMWaveHdr) + BufferSize);
      if lpWaveHdr = nil then
         Error(LoadResStr(IDS_HEADERMEMERROR));

      { Data occurs directly after the header }
      lpWaveHdr^.lpData         := PChar(lpWaveHdr) + sizeOf(TMMWaveHdr);
      lpWaveHdr^.dwBufferLength := BufferSize;
      lpWaveHdr^.dwBytesRecorded:= 0;
      lpWaveHdr^.dwFlags        := 0;
      lpWaveHdr^.dwLoops        := 0;
      lpWaveHdr^.dwUser         := 0;
      lpWaveHdr^.lpNext         := nil;
   end;
end;

{-- TMMWaveOut -----------------------------------------------------------}
procedure TMMWaveOut.FreeWaveHeaders;
Var
   i: integer;

begin
   for i := 0 to FNumBuffers-1 do
   begin
      { unlock and free memory for WaveOutHdr }
      if FWaveOutHdrs[i] <> NIL then
      begin
         FAllocator.FreeBuffer(Pointer(FWaveOutHdrs[i]));
         FWaveOutHdrs[i] := Nil;
      end;
   end;
end;

{-- TMMWaveOut -----------------------------------------------------------}
procedure TMMWaveOut.SetLooping(aValue: Boolean);
begin
   if (aValue <> FLooping) then
   begin
      FLooping := aValue;
      FLoopTempCount := FLoopCount;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMWaveOut -----------------------------------------------------------}
procedure TMMWaveOut.SetLoopCount(aValue: Word);
begin
   if (aValue <> FLoopCount) then
   begin
      FLoopCount := aValue;
      FLoopTempCount := FLoopCount;
   end;
end;

{-- TMMWaveOut -----------------------------------------------------------}
function TMMWaveOut.WaveOutErrorString(WError: integer): String;
Var
   errorDesc: PChar;

begin
   { Convert the numeric return code from an MMSYSTEM function to a string }
   errorDesc := Nil;
   try
      errorDesc := StrAlloc(MAXERRORLENGTH);
      if waveOutGetErrorText(WError, errorDesc, MAXERRORLENGTH) = 0 then
         Result := StrPas(errorDesc)
      else
         Result := LoadResStr(IDS_ERROROUTOFRANGE);

   finally
      StrDispose(errorDesc);
   end;
end;

{-- TMMWaveOut -----------------------------------------------------------}
Procedure TMMWaveOut.SetDeviceID(aValue: TMMDeviceID);
begin
   if (wosOpen in FState) then
       Error(LoadResStr(IDS_PROPERTYOPEN));

   FProductName := LoadResStr(IDS_WONODEVICE);
   FDriverVersion := 0;

   if (FNumDevs > 0) and (aValue >= MapperId) and (aValue < FNumDevs) then
   begin
      { Set the name and other WAVEOUTCAPS properties to match the ID }
      FError := waveOutGetDevCaps(aValue, @FWaveOutCaps, sizeof(TWaveOutCaps));
      if FError = 0 then
      with FWaveOutCaps do
      begin
         FProductName := StrPas(szPname);
         FDriverVersion := vDriverVersion;
      end;
   end;

   { set the new device }
   FDeviceID := aValue;
   if (aValue < MapperId) or (aValue >= FNumDevs) then
       FDeviceID := InvalidID;

   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMWaveOut -----------------------------------------------------------}
function TMMWaveOut.GetDeviceID: TMMDeviceID;
begin
   Result := FDevicEID;
end;

{-- TMMWaveOut -----------------------------------------------------------}
procedure TMMWaveOut.SetProductName(aValue: String);
begin
   ;
end;

{-- TMMWaveOut -----------------------------------------------------------}
function TMMWaveOut.GetProductName: String;
begin
   Result := FProductName;
end;

{-- TMMWaveOut -----------------------------------------------------------}
function TMMWaveOut.QueryDevice(aDeviceID: TMMDeviceID; pwfx: PWaveFormatEx): Boolean;
Var
   aHandle: HWaveOut;

begin
   if (aDeviceID < FNumDevs) and (aDeviceID >= MapperID) and (pwfx <> nil) then
   begin
      { query the Wave output device. }
      Result := WaveOutOpen(@aHandle,
                            aDeviceId,
                            Pointer(pwfx),
                            0, 0,
                            WAVE_FORMAT_QUERY) = 0;
   end
   else Result := False;
end;

{-- TMMWaveOut ------------------------------------------------------------}
procedure TMMWaveOut.SetTimeFormat(aValue: TMMTimeFormats);
begin
   if (aValue <> FTimeFormat) then
   begin
      FTimeFormat := aValue;
   end;
end;

{-- TMMWaveOut ------------------------------------------------------------}
function TMMWaveOut.GetSamplePosition: Cardinal;
Var
   MMTime: TMMTime;

begin
   Result := 0;
   if (wosOpen in FState) then
   begin
      MMTime.wType := Time_Samples;
      FError := WaveOutGetPosition(FHWaveOut, @MMTime, SizeOf(TMMTime));
      if (FError <> 0) or (MMTime.wType <> Time_Samples) then
      begin
         MMTime.wType := Time_Bytes;
         FError := WaveOutGetPosition(FHWaveOut, @MMTime, SizeOf(TMMTime));
         if (FError <> 0) then
             Error('WaveOutGetPosition:'#10#13+WaveOutErrorString(FError));

         MMTime.Sample := wioBytesToSamples(PWaveFormat,MMTime.cb);
      end;
      Result := MMTime.Sample;
      {asm
         mov   eax, $FFFF0000
         add   Result, eax
      end;}
   end;
end;

{-- TMMWaveOut ------------------------------------------------------------}
function TMMWaveOut.GetInternalPosition: Int64;
var
   Samples,Pos: int64;
   S: Cardinal;
   WrapSize: int64;
begin
   Result := 0;
   if (wosOpen in FState) and (PWaveFormat <> Nil) and not FCloseIt then
   begin
      { adjust if Looped or FullDuplex }
      S := GetSamplePosition;
      {$IFDEF WIN32}
      asm
         mov   eax, S
         mov   dword ptr Pos[0], eax
         xor   eax, eax
         mov   dword ptr Pos[4], eax

         mov   eax, Self
         mov   eax, TMMWaveOut(eax).FWrapSize
         mov   dword ptr WrapSize[0], eax
         xor   eax, eax
         mov   dword ptr WrapSize[4], eax
      end;

      Samples := (FWrapArrounds*WrapSize)+(Pos+FOldPosition)-FLoopPos;
      {$ELSE}
      Samples := (S+FOldPosition)-FLoopPos;
      {$ENDIF}

      case FTimeFormat of
           tfMilliSecond: Result := wioSamplesToTime64(PWaveFormat,Samples);
           tfByte       : Result := wioSamplesToBytes64(PWaveFormat,Samples);
           tfSample     : Result := Samples;
      end;
   end;
end;

{-- TMMWaveOut ------------------------------------------------------------}
function TMMWaveOut.GetPosition: MM_int64;
{$IFNDEF DELPHI4}
var
   Temp: TLargeInteger;
{$ENDIF}
begin
   {$IFDEF DELPHI4}
   Result := GetInternalPosition;
   {$ELSE}
   Temp.QuadPart := GetInternalPosition;
   Result := Temp.LowPart;
   {$ENDIF}
end;

{-- TMMWaveOut ------------------------------------------------------------}
function TMMWaveOut.GetPositionHigh: Cardinal;
{$IFNDEF DELPHI4}
var
   Temp: TLargeInteger;
{$ENDIF}
begin
   {$IFDEF DELPHI4}
   Result := (GetInternalPosition shr 32);
   {$ELSE}
   Temp.QuadPart := GetInternalPosition;
   Result := Temp.HighPart;
   {$ENDIF}
end;

{-- TMMWaveOut -----------------------------------------------------------}
Procedure TMMWaveOut.SetCallBackMode(aValue: TMMCBMode);
begin
   if (wosOpen in FState) then
      Error(LoadResStr(IDS_PROPERTYOPEN));

   if (aValue <> FCallBackMode) then
   begin
      if (aValue = cmCallBack) then
      begin
         {$IFDEF WIN32}
         if not _Win95_ then
         {$ENDIF}
         begin
            Application.MessageBox('"CallBacks" are called at interrupt time !'#10#13+
                                   'This is currently only supported under Windows 95',
                                   'TMMWaveOut', MB_OK);
            exit;
         end;
      end;
      FCallBackMode := aValue;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK3}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMWaveOut -----------------------------------------------------------}
function TMMWaveOut.GetCallBackMode: TMMCBMode;
begin
   Result := FCallBackMode;
end;

{-- TMMWaveOut -----------------------------------------------------------}
Procedure TMMWaveOut.SetNumBuffers(aValue: integer);
begin
   if (aValue <> FNumBuffers) AND (aValue > 1) then
   begin
      if (wosOpen in FState) then
          Error(LoadResStr(IDS_PROPERTYOPEN));

      FNumBuffers := Min(aValue,MAXOUTBUFFERS);
   end;
end;

{-- TMMWaveOut -----------------------------------------------------------}
function TMMWaveOut.GetNumBuffers: integer;
begin
   Result := FNumBuffers;
end;

{-- TMMWaveOut -----------------------------------------------------------}
Procedure TMMWaveOut.SetPWaveFormat(aValue: PWaveFormatEx);
begin
   { stop and close the device }
   Close;
   inherited SetPWaveFormat(aValue);
end;

{-- TMMWaveOut -----------------------------------------------------------}
Procedure TMMWaveOut.SetBufferSize(aValue: Longint);
begin
   if (aValue <> inherited GetBufferSize) then
   begin
      if (wosOpen in FState) then
          Error(LoadResStr(IDS_PROPERTYOPEN));

      if assigned(FAllocator) then
         FAllocator.Discard;

      inherited SetBufferSize(Max(aValue,MINBUFFERSIZE));
   end;
end;

{-- TMMWaveOut -----------------------------------------------------------}
function TMMWaveOut.GetBufferSize: Longint;
begin
   Result := inherited GetBufferSize;
end;

{-- TMMWaveOut -----------------------------------------------------------}
Procedure TMMWaveOut.PrepareWaveHeader(lpWaveHdr: PWaveHdr);
begin
   if lpWaveHdr <> Nil then
   begin
      { Prepare waveform header for playing }
      WaveOutPrepareHeader(FHWaveOut, lpWaveHdr, sizeOf(TWaveHdr));
   end;
end;

{-- TMMWaveOut -----------------------------------------------------------}
Procedure TMMWaveOut.UnPrepareWaveHeaders;
Var
   i: integer;
   TimeOut: Longint;

begin
   {$IFDEF _MMDEBUG}
   DebugStr(1,' ');
   {$ENDIF}

   for i := 0 to FBuffersUsed-1 do
   begin
      if (FWaveOutHdrs[i] <> Nil) then
      begin
         TimeOut := 65000;
         { wait until the buffer is marked as done }
         repeat
             dec(TimeOut);
         until (FWaveOutHdrs[i]^.dwFlags and WHDR_DONE = WHDR_DONE) or (TimeOut = 0);

         { mark buffer as done }
         if (TimeOut = 0) then FWaveOutHdrs[i]^.dwFlags := WHDR_DONE;

         { unprepare buffer }
         WaveOutUnprepareHeader(FHWaveOut, FWaveOutHdrs[i], sizeOf(TWAVEHDR));

         {$IFDEF _MMDEBUG}
         DebugStr(1,'UnprepareHeader '+IntToStr(i));
         {$ENDIF}
      end;
   end;

   {$IFDEF _MMDEBUG}
   DebugStr(1,' ');
   {$ENDIF}
end;

{-- TMMWaveOut -----------------------------------------------------------}
Function TMMWaveOut.LoadWaveHeader(lpWaveHdr: PWaveHdr): Longint;
begin
   Result := 0;
   FMoreBuffers := False;

   if (lpWaveHdr <> nil) then
   begin
      {$IFDEF _MMDEBUG}
      DebugStr(2,'Try to load Buffer '+IntToStr(lpWaveHdr^.dwUser));
      {$ENDIF}

      BufferLoad(lpWaveHdr, FMoreBuffers);

      Result := lpWaveHdr^.dwBytesRecorded;
      if Result <= 0 then FMoreBuffers := False;

      {$IFDEF _MMDEBUG}
      DebugStr(2,'Buffer '+IntToStr(lpWaveHdr^.dwUser)+' loaded');
      {$ENDIF}
   end;
end;

{-- TMMWaveOut -----------------------------------------------------------}
procedure TMMWaveOut.QueueWaveHeader(lpWaveHdr: PWaveHdr);
begin
   { this is the chance to modify the data in the buffer !!! }
   DoBufferFilled(lpWaveHdr);

   if not FStopping then
   begin
      if not FIX_BUFFERS then
         WaveOutPrepareHeader(FHWaveOut, lpWaveHdr, sizeOf(TWaveHdr))
      else
         { reset flags field (remove WHDR_DONE attribute) }
         lpWaveHdr^.dwFlags := lpWaveHdr^.dwFlags and not WHDR_DONE or WHDR_PREPARED;