mmdsystm.pas

一套及时通讯的原码

   Handles: PWOHandleArray;
   RecCount: Integer;
   Recs: PFtArray;

  procedure CollectHandles;
  var
     lpft: PMMft;
     Index, RecIndex, i: Integer;
  begin
     EnterCritical;
     try
        HandleCount := 1;
        RecCount := 0;
        lpft := lpMMFt;
        while lpft <> nil do
        if tnEvents in lpft^.NtfResources then
        begin
           Inc(HandleCount, BUFFER_PARTS);
           Inc(RecCount);
           lpft := lpft^.NextMMFt;
        end;
       GetMem(Handles, HandleCount * SizeOf(THandle));
       GetMem(Recs, RecCount * SizeOf(Recs^[0]));
       Index := 0;
       RecIndex := 0;
       lpft := lpMMFt;
       while lpft <> nil do
       if tnEvents in lpft^.NtfResources then
       begin
          Recs[RecIndex] := lpft;
          Inc(RecIndex);
          for i := 0 to BUFFER_PARTS-1 do
          begin
            Handles^[Index] := lpft^.NotifyPts[i].hEventNotify;
            Inc(Index);
          end;
          lpft := lpft^.NextMMFt;
       end;
       Handles^[Index] := FSystemEvent;
     finally
       LeaveCritical;
     end;
  end;

  procedure FreeHandles;
  begin
     FreeMem(Handles, HandleCount * SizeOf(THandle));
     FreeMem(Recs, RecCount * SizeOf(Recs^[0]));
     Handles := nil;
     Recs := nil;
  end;

var
  WaitResult: Integer;

begin
   while not Terminated do
   begin
      Priority := tpHigher;

      CollectHandles;
      WaitResult := WaitForMultipleObjects(HandleCount, Handles,
                                           False, NOTIFICATIONTHREAD_TIMEOUT);
      if not Terminated then
      begin
         if WaitResult = WAIT_OBJECT_0 + HandleCount - 1 then
           { System Event - do nothing just starting another loop }
         else if (WaitResult >= WAIT_OBJECT_0) and (WaitResult < WAIT_OBJECT_0 + HandleCount - 1) then
         begin
            { Process next block ... }
            ProcessData(Recs^[(WaitResult - WAIT_OBJECT_0) div BUFFER_PARTS]);
         end;
      end;
      FreeHandles;
   end;
end;

{------------------------------------------------------------------------}
procedure DSNotificationThread_Addref;
begin
   if DSNotificationThread_RefCount = 0 then
      DSNotificationThread := TDSNotificationThread.Create;
   Inc(DSNotificationThread_RefCount);
end;

{------------------------------------------------------------------------}
procedure DSNotificationThread_Release;
begin
   if DSNotificationThread_RefCount > 0 then
   begin
      Dec(DSNotificationThread_RefCount);
      if DSNotificationThread_RefCount = 0 then
      begin
         DSNotificationThread.Terminate;
         SetEvent(DSNotificationThread.FSystemEvent);
         DSNotificationThread.Free;
         DSNotificationThread := nil;
      end;
   end;
end;

{------------------------------------------------------------------------}
function DoneNotifications(lpft: PMMft): HResult;
var
  i: integer;
begin
   with lpft^ do
   begin
     if tnThread in NtfResources then
     begin
       DSNotificationThread_Release;
       Exclude(NtfResources, tnThread);
     end;

     if tnInterface in NtfResources then
     begin
       lpDSBN.Release;
       lpDSBN := nil;
       Exclude(NtfResources, tnInterface);
     end;

     if tnEvents in NtfResources then
     begin
       for i := 0 to BUFFER_PARTS-1 do
         with NotifyPts[i] do
           CloseHandle(hEventNotify);
       Exclude(NtfResources, tnEvents);
     end;
  end;
  Result := S_OK;
end;

{------------------------------------------------------------------------}
function InitializeNotifications(lpft: PMMft): HResult;
var
  i: integer;
begin
   with lpft^ do
   try
      NtfResources := [];
      {$IFDEF USE_NOTIFICATION}
      if lpDSB.QueryInterface(IID_IDirectSoundNotify, lpDSBN) <> S_OK then
      {$ENDIF}
      begin
         lpDSBN := nil;
         Result := E_NOTIMPL;
         exit;
      end;
      Include(NtfResources, tnInterface);

      for i := 0 to BUFFER_PARTS-1 do
      with NotifyPts[i] do
      begin
         dwOffset := (i + 1) * EachTick - 1;
         hEventNotify := CreateEvent(nil, False, False, nil);
      end;
      Include(NtfResources, tnEvents);

      OleCheck(lpDSBN.SetNotificationPositions(BUFFER_PARTS, @NotifyPts[0]));

      DSNotificationThread_Addref;
      Include(NtfResources, tnThread);

      Result := S_OK;
   except
      DoneNotifications(lpft);
      Result := E_FAIL;
   end;
end;

{------------------------------------------------------------------------}
procedure DSSetHWND(hWaveOut: HWAVEOUT; hw: HWND);
begin
   if hWaveOut = 0 then DSoundHW := hw
   else if LoadDSoundDLL then
           PMMft(hWaveOut)^.lpDS.SetCooperativeLevel(hw,DSSCL_PRIORITY);
end;

{------------------------------------------------------------------------}
function DSDirectSoundCreate(lpGUID: PGUID; var lpDS: IDirectSound;
                             pUnkOuter: IUnknown): HRESULT;
Var
   lpft: PMMft;

begin
   lpft := lpMMft;
   while (lpft <> Nil) do
   begin
      if (lpft^.lpDS <> nil) and (lpft^.lpGUID = lpGUID) then
      begin
         lpDS   := lpft^.lpDS;
         Result := 0;
         exit;
      end;
      lpft := lpft^.NextMMft;
   end;
   Result := DirectSoundCreate(lpGUID, lpDS, nil);
end;

{------------------------------------------------------------------------}
function DSCreatePrimaryBuffer(hWaveOut: HWAVEOUT; lpFormat: PWaveFormatEx): HRESULT;
var
   lpft: PMMft;
   wfx: TWaveFormatEx;
   BufferDesc: TDSBUFFERDESC;
   Bits, Channels, Rate: integer;

begin
   lpft := lpMMft;
   while (lpft <> Nil) do
   begin
      if (lpft^.lpDS = PMMft(hWaveOut)^.lpDS) and (lpft^.lpDSP <> nil) then
      begin
         PMMft(hWaveOut)^.lpDSP := lpft^.lpDSP;
         PMMft(hWaveOut)^.lpDSP.GetFormat(@wfx, sizeOf(wfx), nil);
         Bits := Max(wfx.wBitsPerSample,lpFormat^.wBitsPerSample);
         Channels := Max(wfx.nChannels,lpFormat^.nChannels);
         Rate := Max(wfx.nSamplesPerSec,lpFormat^.nSamplesPerSec);
         pcmBuildWaveHeader(@wfx, Bits,Channels,Rate);
         PMMft(hWaveOut)^.lpDSP.SetFormat(@wfx);
         Result := DS_OK;
         exit;
      end;
      lpft := lpft^.NextMMft;
   end;

   FillChar(BufferDesc, SizeOf(TDSBUFFERDESC), 0);
   with BufferDesc do
   begin
      dwSize := SizeOf(TDSBUFFERDESC);
      dwFlags := DSBCAPS_PRIMARYBUFFER;
   end;
   Result := PMMft(hWaveOut)^.lpDS.CreateSoundBuffer(BufferDesc,PMMft(hWaveOut)^.lpDSP,nil);
   if Result = DS_OK then
   begin
      PMMft(hWaveOut)^.lpDSP.SetFormat(lpFormat);
      PMMft(hWaveOut)^.lpDSP.Play(0,0,DSBPLAY_LOOPING);
   end;
end;

{------------------------------------------------------------------------}
function DSWaveOutOpen(lphWaveOut: PHWAVEOUT; uDeviceID: UINT;
                       lpFormat: PWaveFormatEx;
                       dwCallback, dwInstance, dwFlags: DWORD): MMRESULT;
Label DSOPEN_EXIT,cont;
Var
   hw: HWND;
   p1, p2: PChar;
   l1, l2: DWORD;
   lpft,lpft2: PMMFt;
   DSBDescr: TDSBUFFERDESC;
   DSCaps: TDSCAPS;
   Proc,CurProc: DWORD;
   m: integer;

begin
   Result := 1;
   if (Not LoadDSoundDLL) or (lpFormat = Nil) or
      (dwFlags and WAVE_ALLOWSYNC = WAVE_ALLOWSYNC) then exit;

   if (DSoundHW <> 0) then hw := DSoundHW
   else
   begin
      hw := GetTopWindow(0);
      CurProc := GetCurrentProcessId;
      while (hw <> 0) do
      begin
         GetWindowThreadProcessId(hw, @Proc);
         if (Proc = CurProc) then break;
         hw := GetWindow(hw, GW_HWNDNEXT);
      end;
      if (hw = 0) then hw := GetDesktopWindow;
   end;

   lpft := GlobalAllocPtr(GHND,sizeOf(TMMft));
   if (lpft = Nil) then exit;

   FillChar(lpft^, sizeOf(TMMft), 0);
   if DSDirectSoundCreate(PGUID(uDeviceID), lpft^.lpDS, Nil) <> DS_OK then
   begin
      GlobalFreePtr(lpft);
      exit;
   end;

   lpft^.lpGUID := PGUID(uDeviceID);
   lpft^.lpDS.SetCooperativeLevel(hw,DSSCL_PRIORITY);

   FillChar(DSBDescr, sizeOf(DSBDescr), 0);
   DSBDescr.lpwfxFormat := lpFormat;
   DSBDescr.dwSize := sizeOf(TDSBUFFERDESC);

   DSBDescr.dwFlags := DSBCAPS_STICKYFOCUS or DSBCAPS_GETCURRENTPOSITION2 or
                       DSBCAPS_CTRLPOSITIONNOTIFY or DSBCAPS_GLOBALFOCUS;
   if (dwFlags and DS_NEEDVOLUME = DS_NEEDVOLUME) then
      DSBDescr.dwFlags := DSBDescr.dwFlags or DSBCAPS_CTRLVOLUME;
   if (dwFlags and DS_NEEDPAN = DS_NEEDPAN) then
      DSBDescr.dwFlags := DSBDescr.dwFlags or DSBCAPS_CTRLPAN;
   if (dwFlags and DS_NEEDFREQ = DS_NEEDFREQ) then
      DSBDescr.dwFlags := DSBDescr.dwFlags or DSBCAPS_CTRLFREQUENCY;

   { look if we have a emulated device }
   FillChar(DSCaps, SizeOf(TDSCAPS), 0);
   DSCaps.dwSize := SizeOf(TDSCAPS);
   lpft^.lpDS.GetCaps(DSCaps);
   lpft^.Emulated := (DSCaps.dwFlags and DSCAPS_EMULDRIVER) > 0;

   lpft^.EachTick := (lpFormat^.nAvgBytesPerSec div (TIMERRATE div 2)) and not 3;
   lpft^.BufferSize := lpft^.Eachtick * BUFFER_PARTS;
   if lpft^.Emulated then lpft^.BufferSize := lpft^.BufferSize*2;
   DSBDescr.dwBufferBytes := lpft^.BufferSize;

   if lpFormat^.wBitsPerSample = 8 then
      lpft^.SilenceVal := $80
   else
      lpft^.SilenceVal := 0;

   lpft^.DataRate := lpFormat^.nAvgBytesPerSec;

   if lpft^.lpDS.CreateSoundBuffer(DSBDescr,lpft^.lpDSB,Nil) <> DS_OK then
   begin
      { ev. older DSound version which doesn't support DSBCAPS_STICKYFOCUS }
      DSBDescr.dwFlags := DSBDescr.dwFlags and not (DSBCAPS_STICKYFOCUS + DSBCAPS_GLOBALFOCUS);
      if lpft^.lpDS.CreateSoundBuffer(DSBDescr,lpft^.lpDSB,Nil) <> DS_OK then
         goto DSOPEN_EXIT;
   end;

   if (dwFlags and WAVE_FORMAT_QUERY = WAVE_FORMAT_QUERY) then
   begin
      Result := 0;
      goto DSOPEN_EXIT;
   end;

   if InitializeNotifications(lpft) = E_FAIL then
      goto DSOPEN_EXIT;

   m := -10000;
   lpft^.lpDSB.SetVolume(m);
   if lpft^.lpDSB.Lock(0, lpft^.BufferSize,p1,l1,p2,l2,0) <> DS_OK then
      goto DSOPEN_EXIT;

   if (p1 <> Nil) then FillChar(p1^,l1, lpft^.SilenceVal);
   if (p2 <> Nil) then FillChar(p2^,l2, lpft^.SilenceVal);

   if lpft^.lpDSB.Unlock(p1,l1,p2,l2) <> DS_OK then
      goto DSOPEN_EXIT;

   if (dwFlags and CALLBACK_FUNCTION = CALLBACK_FUNCTION) then
   begin
      if (dwCallBack <> 0) then lpft^.CallBack := dwCallBack
      else goto DSOPEN_EXIT;
      lpft^.CBInstance := dwInstance;
      lpft^.CallBackMode := CALLBACK_FUNCTION;
   end
   else if (dwFlags and CALLBACK_WINDOW = CALLBACK_WINDOW) then
   begin
      if (dwCallBack <> 0) then lpft^.CallBack := dwCallBack
      else goto DSOPEN_EXIT;
      lpft.CallBackMode := CALLBACK_WINDOW;
   end
   else if (dwFlags and CALLBACK_THREAD = CALLBACK_THREAD) then
   begin
      if (dwCallBack <> 0) then lpft^.CallBack := dwCallBack
      else goto DSOPEN_EXIT;
      lpft.CallBackMode := CALLBACK_THREAD;
   end
   else goto DSOPEN_EXIT;

   InitCritical;

   lpft^.NextMMft := lpMMft;
   lpMMft := lpft;

   lphWaveOut^ := HWAVEOUT(lpft);
   NotifyMessage(lpft, MM_WOM_OPEN, lphWaveOut^, 0);
   Result := 0;
   exit;

DSOPEN_EXIT:

   DoneNotifications(lpft);

   if (lpft^.lpDSB <> Nil) then lpft^.lpDSB.Release;
   if (lpMMft = Nil) then lpft^.lpDS.Release
   else
   begin
      lpft2 := lpMMft;
      while lpft2 <> nil do
      begin
         if lpft2^.lpGUID = lpft^.lpGUID then goto cont;
         lpft2 := lpft2^.NextMMft;
      end;
      lpft^.lpDS.Release;
   end;

cont:
   GlobalFreePtr(lpft);