mmdswout.pas

一套及时通讯的原码

procedure TMMDSWaveOut.SetProductName(aValue: String);
begin
   ;
end;

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

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

begin
   if (DeviceID < NumDevs) and (DeviceID >= 0) and (pwfx <> nil) then
   begin
      { now query Wave output device. }
      Result := DSWaveOutOpen(@aHandle,
                              Integer(Devices[DeviceID].lpGUID),
                              Pointer(pwfx),
                              0, 0,
                              WAVE_FORMAT_QUERY) = 0;
   end
   else Result := False;
end;

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

{-- TMMDSWaveOut --------------------------------------------------------}
function TMMDSWaveOut.GetSamplePosition: Longint;
Var
   MMTime: TMMTime;

begin
   Result := 0;
   if (dssOpen in FState) then
   begin
      MMTime.wType := Time_Samples;
      FError := DSWaveOutGetPosition(FHDSWaveOut, @MMTime, SizeOf(TMMTime));
      if FError <> 0 then
         Error('DSWaveOutGetPosition:'#10#13+LoadResStr(IDS_POSITIONERROR));

      Result := MMTime.Sample;
   end;
end;

{-- TMMDSWaveOut ----------------------------------------------------------}
function TMMDSWaveOut.GetPosition: MM_int64;
Var
   Samples: Longint;

begin
   Result := 0;
   EnterCritical;
   try
      if (dssOpen in FState) and (PWaveFormat <> Nil) and not FClosing  then
      begin
         { adjust if Looped or FullDuplex }
         Samples := (GetSamplePosition+FOldPosition)-FLoopPos;

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

   finally
      LeaveCritical;
   end;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.SetVolume(aValue: Longint);
begin
   if (aValue <> FVolume) then
   begin
      FVolume := MinMax(aValue,DSBVOLUME_MIN,DSBVOLUME_MAX);
      if (dssOpen in FState) then
         DSWaveOutSetVolume(FHDSWaveOut, FVolume);
   end;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
function TMMDSWaveOut.GetVolume: Longint;
begin
   if (dssOpen in FState) then
      DSWaveOutGetVolume(FHDSWaveOut, @FVolume);

   Result := FVolume;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.SetPan(aValue: Longint);
begin
   if (aValue <> FPan) then
   begin
      FPan := MinMax(aValue,DSBPAN_LEFT,DSBPAN_RIGHT);
      if (dssOpen in FState) then
         DSWaveOutSetPan(FHDSWaveOut, FPan);
   end;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
function TMMDSWaveOut.GetPan: Longint;
begin
   if (dssOpen in FState) then
      DSWaveOutGetPan(FHDSWaveOut, @FPan);

   Result := FPan;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.SetRate(aValue: Longint);
begin
   if (aValue <> FRate) then
   begin
      FRate := Min(aValue,DSBFREQUENCY_MAX);
      if (dssOpen in FState) then
         DSWaveOutSetPlayBackRate(FHDSWaveOut, FRate);
   end;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
function TMMDSWaveOut.GetRate: Longint;
begin
   if (dssOpen in FState) then
      DSWaveOutGetPlayBackRate(FHDSWaveOut, @FRate);

   Result := FRate;
end;

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

   if (aValue <> FCallBackMode) then
   begin
      if (aValue = cmCallBack) then
      begin
         Application.MessageBox('"CallBacks" are not supported with DirectSound',
                                'TMMDSWaveOut', MB_OK);
         exit;
      end;
      FCallBackMode := aValue;
   end;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
function TMMDSWaveOut.GetCallBackMode: TMMCBMode;
begin
   Result := FCallbackMode;
end;

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

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

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

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

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

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

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

{-- TMMDSWaveOut --------------------------------------------------------}
Procedure TMMDSWaveOut.PrepareWaveHeader(lpWaveHdr: PWaveHdr);
begin
   if lpWaveHdr <> Nil then
   begin
      { Prepare waveform header for playing }
      FError := DSWaveOutPrepareHeader(FHDSWaveOut,
                                       lpWaveHdr,
                                       sizeOf(TWaveHdr));
      if FError <> 0 then
         Error('DSWaveOutPrepareHeader:'#10#13+LoadResStr(IDS_PREPAREERROR));
   end;
end;

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

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

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

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

         { unprepare buffer }
         FError := DSWaveOutUnprepareHeader(FHDSWaveOut,
                                            FDSWaveOutHdrs[i],
                                            sizeOf(TWAVEHDR));
         if FError <> 0 then
            Error('DSWaveOutUnprepareHeader:'#10#13+LoadResStr(IDS_UNPREPAREERROR));

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

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

{-- TMMDSWaveOut --------------------------------------------------------}
Function TMMDSWaveOut.LoadWaveHeader(lpWaveHdr: PWaveHdr): Longint;
begin
   FMoreBuffers := False;
   try
      BufferLoad(lpWaveHdr, FMoreBuffers);
   except
      Result := 0;
      raise;
   end;
   Result := lpWaveHdr^.dwBytesRecorded;
   if Result <= 0 then FMoreBuffers := False;
end;

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

   if not FStopping then
   begin
      { reset flags field (remove WHDR_DONE attribute) }
      lpWaveHdr^.dwFlags := WHDR_PREPARED;

      { now queue the buffer for output }
      FError := DSWaveOutWrite(FHDSWaveOut,
                               lpWaveHdr,
                                SizeOf(TWAVEHDR));
      if FError <> 0 then
         Error('DSWaveOutWrite:'#10#13+LoadResStr(IDS_WRITEERROR));

      inc(FBufferCounter);

      {$IFDEF _MMDEBUG}
      DebugStr(2,'Wave-Header '+IntToStr(lpWaveHdr^.dwUser)+' queued');
      {$ENDIF}
   end;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.SynchronizeVCL(VCLProc: TThreadMethod);
begin
   if (FCallBackMode = cmThread) and (FOutEvent <> 0) then
   begin
      FOutThread.Synchronize(VCLProc);
   end
   else VCLProc;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.InitThread;
begin
   if (FCallBackMode = cmThread) then
   begin
      EnterCritical;
      try
        FThreadError := False;

        { create event objects }
        FOutEvent   := CreateEvent(nil, False, False, nil);
        FCloseEvent := CreateEvent(nil, False, False, nil);
        FResetEvent := CreateEvent(nil, True, False, nil);


        { create the output thread }
        FOutThread := TMMDSWaveOutThread.CreateSuspended(Self);
        if (FOutThread = nil) then
            Error('DSWaveOut:'#10#13+LoadResStr(IDS_THREADERROR));

        FOutThread.FreeOnTerminate := True;
        FOutThread.Resume;

        { Wait for it to start... }
        if WaitForSingleObject(FOutEvent, 1000) <> WAIT_OBJECT_0 then
           Error('DSWaveOut:'#10#13+LoadResStr(IDS_THREADERROR));

        {$IFDEF _MMDEBUG}
        DebugStr(0,'Thread Started');
        {$ENDIF}

      finally
        LeaveCritical;
      end;
   end;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.DoneThread;
begin
   if (FCallBackMode = cmThread) and not FThreadError then
   begin
      { Force the output thread to close... }
      SetEvent(FCloseEvent);

      { ...and wait for it to die }
      WaitForSingleObject(FOutEvent, 5000);

      { close all events and remove critical section }
      CloseEvents;

      {$IFDEF _MMDEBUG}
      DebugStr(0,'Thread Terminated');
      {$ENDIF}
   end;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.CloseEvents;
begin
   { release events }
   CloseHandle(FOutEvent);
   CloseHandle(FCloseEvent);
   CloseHandle(FResetEvent);

   { Free the critical section }
   DoneCritical;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.InitCritical;
begin
   { create critical section object }
   FillChar(DataSection, SizeOf(DataSection), 0);
   InitializeCriticalSection(DataSection);
   DataSectionOK := True;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.EnterCritical;
begin
   if DataSectionOK then
      EnterCriticalSection(DataSection);
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.LeaveCritical;
begin
   if DataSectionOK then
      LeaveCriticalSection(DataSection);
end;

{-- TMMDSWaveOut --------------------------------------------------------}
procedure TMMDSWaveOut.DoneCritical;
begin
   if DataSectionOK then
   begin
      DataSectionOK := False;
      DeleteCriticalSection(DataSection);
   end;
end;

{-- TMMDSWaveOut --------------------------------------------------------}
Procedure TMMDSWaveOut.Open;
var
   Timeout: integer;
begin
   if (NumDevs = 0) then
      Error(LoadResStr(IDS_DSNODEVICE));

   if (DeviceID = InvalidID) then
       Error(LoadResStr(IDS_INVALIDDEVICEID));

   if (PWaveFormat = nil) then
      Error(LoadResStr(IDS_NOFORMAT));

   if (dssOpen in FState) then Close;

   if (Not(dssOpen in FState)) and not FClosing then
   begin
      {$IFDEF _MMDEBUG}
      DB_Clear;
      {$ENDIF}

      FClosing := False;
      FReseting := False;
      FStopping := False;
      try
         if not QueryDevice(FDeviceID, PWaveFormat) then
            Error('DSWaveOutOpen:'#10#13+LoadResStr(IDS_CANTPLAY));

         { Create the window for callback notification }
         if (FHandle = 0) then FHandle := AllocateHwnd(DSWaveOutHandler);

         FHDSWaveOut := 0;
         FCloseIt := False;

         inherited Opened;