Delphi控件源码

开发平台：
Delphi

MMDSystm.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49(0)351-8037944               =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/index.html               =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 13.11.98 - 03:44:47 $                                        =}
{========================================================================}
unit MMDSystm;
{$C FIXED PRELOAD PERMANENT}
{$I COMPILER.INC}
{.$DEFINE USE_NOTIFICATION}
interface
uses
    Windows,
    SysUtils,
    Classes,
    MMOLE2,
    MMSystem,
    MMObj,
    MMUtils,
    MMRegs,
    MMWaveIO,
    MMPCMSup,
    MMDSound;
{ Emulated devices are very, very slow:
  change this value to adjust the buffer return time for emulated drivers
}
const
    {$IFDEF CBUILDER3} {$EXTERNALSYM TIMEADJUST} {$ENDIF}
    TIMEADJUST    : integer = 60;
    EXACTRETURN   : Boolean = True;
const
    {$IFDEF CBUILDER3} {$EXTERNALSYM DS_NEEDVOLUME} {$ENDIF}
    DS_NEEDVOLUME = $10000000;
    {$IFDEF CBUILDER3} {$EXTERNALSYM DS_NEEDPAN} {$ENDIF}
    DS_NEEDPAN    = $20000000;
    {$IFDEF CBUILDER3} {$EXTERNALSYM DS_NEEDFREQ} {$ENDIF}
    DS_NEEDFREQ   = $40000000;
procedure DSSetHWND(hWaveOut: HWAVEOUT; hw: HWND);
function  DSCreatePrimaryBuffer(hWaveOut: HWAVEOUT; lpFormat: PWaveFormatEx): HRESULT;
function  DSWaveOutOpen(lphWaveOut: PHWAVEOUT; uDeviceID: UINT; lpFormat: PWaveFormatEx;
                        dwCallback, dwInstance, dwFlags: DWORD): MMRESULT; stdcall;
function  DSWaveOutClose(hWaveOut: HWAVEOUT): MMRESULT;
function  DSWaveOutPrepareHeader(hWaveOut: HWAVEOUT; lpWaveHdr: PWaveHdr;
                                 uSize: UINT): MMRESULT;
function  DSWaveOutUnprepareHeader(hWaveOut: HWAVEOUT; lpWaveHdr: PWaveHdr;
                                   uSize: UINT): MMRESULT;
function  DSWaveOutWrite(hWaveOut: HWAVEOUT; lpWaveHdr: PWaveHdr;
                         uSize: UINT): MMRESULT;
function  DSWaveOutPause(hWaveOut: HWAVEOUT): MMRESULT;
function  DSWaveOutRestart(hWaveOut: HWAVEOUT): MMRESULT;
function  DSWaveOutReset(hWaveOut: HWAVEOUT): MMRESULT;
function  DSWaveOutGetPosition(hWaveOut: HWAVEOUT; lpInfo: PMMTime;
                               uSize: UINT): MMRESULT;
function  DSWaveOutSetVolume(hWaveOut: HWAVEOUT; dwVolume: DWORD): MMRESULT;
function  DSWaveOutGetVolume(hWaveOut: HWAVEOUT; lpdwVolume: PDWORD): MMRESULT;
function  DSWaveOutSetPan(hWaveOut: HWAVEOUT; dwPan: DWORD): MMRESULT;
function  DSWaveOutGetPan(hWaveOut: HWAVEOUT; lpdwPan: PDWORD): MMRESULT;
function  DSWaveOutSetPlaybackRate(hWaveOut: HWAVEOUT; dwRate: DWORD): MMRESULT;
function  DSWaveOutGetPlaybackRate(hWaveOut: HWAVEOUT; lpdwRate: PDWORD): MMRESULT;
implementation
uses MMMulDiv,MMDSPObj;
const
   TIMERRATE            = 32;               { times per second              }
   BUFFER_PARTS         = 4;                { Divisions of secondary buffer }
   BUFFER_PRELOAD       = BUFFER_PARTS;     { Number of prefill buffers     }
type
    TMMThreadNotificationResources = set of (tnInterface, tnEvents, tnThread);
    PMMft = ^TMMft;
    TMMft = record
       First       : PWaveHdr;
       lpDS        : IDIRECTSOUND;
       lpDSP       : IDIRECTSOUNDBUFFER;
       lpDSB       : IDIRECTSOUNDBUFFER;
       lpGUID      : PGUID;
       NextMMFt    : PMMFt;
       CallBackMode: DWORD;
       CallBack    : DWORD;
       CBInstance  : DWORD;
       EachTick    : DWORD;
       Buffersize  : DWORD;
       NextPos     : DWORD;
       TotalWritten: DWORD;
       TotalPlayed : DWORD;
       LastPlayPos : DWORD;
       SilenceBytes: DWORD;
       EndTime     : DWORD;
       Volume      : DWORD;
       UpdateVolume: Boolean;
       Started     : Boolean;
       Paused      : Boolean;
       DataRate    : DWORD;
       SilenceVal  : Byte;
       Emulated    : Boolean;
        { Playback notification via thread }
       NtfResources: TMMThreadNotificationResources;
       lpDSBN      : IDirectSoundNotify;
       NotifyPts   : array[0..BUFFER_PARTS-1] of TDSBPOSITIONNOTIFY;
    end;
const
   lpMMFt       : PMMFt = Nil;
   DSoundHW     : HWND  = 0;
   TimerInit    : DWORD = 0;
   TimerID      : DWORD = 0;
   AllNtfResources = [tnInterface, tnEvents, tnThread];
var
   DataSection  : TRtlCriticalSection;
   DataSectionOK: Boolean = False;
{------------------------------------------------------------------------}
procedure InitCritical;
begin
   if (lpMMFt = nil) then
   begin
      { create critical section object }
      FillChar(DataSection, SizeOf(DataSection), 0);
      InitializeCriticalSection(DataSection);
      DataSectionOK := True;
   end;
end;
{------------------------------------------------------------------------}
procedure DoneCritical;
begin
   if (lpMMFt = nil) and DataSectionOK then
   begin
      DataSectionOK := False;
      DeleteCriticalSection(DataSection);
   end;
end;
{------------------------------------------------------------------------}
procedure EnterCritical;
begin
   if DataSectionOK then EnterCriticalSection(DataSection);
end;
{------------------------------------------------------------------------}
procedure LeaveCritical;
begin
   if DataSectionOK then LeaveCriticalSection(DataSection);
end;
{------------------------------------------------------------------------}
procedure NotifyMessage(lpft: PMMft; Msg: UINT; wParam: WPARAM; lParam: LPARAM);stdcall;
type
    TWaveOutFunc = procedure(hWaveOut: HWaveOut;wMsg:UINT;dwInstance,dwParam1,dwParam2:Longint);stdcall;
begin
   if (lpft <> nil) then
   with lpft^ do
   begin
      case CallBackMode of
         CALLBACK_WINDOW: PostMessage(CallBack,Msg,wParam,lParam);
         CALLBACK_THREAD: PostThreadMessage(CallBack,Msg,wParam,lParam);
       CALLBACK_FUNCTION: TWaveOutFunc(CallBack)(integer(lpft),Msg,CBInstance,wParam,lParam);
      end;
   end;
end;
{------------------------------------------------------------------------}
procedure DoneMarker(uTimerID, uMessage: UINT; user, dw1, dw2: DWORD);stdcall;
begin
   if (user <> 0) then
   with PMMWaveHdr(user)^ do
   begin
      wh.dwFlags := wh.dwFlags or WHDR_DONE; { Header is done }
      NotifyMessage(PMMft(dwUser1), MM_WOM_DONE, dwUser1, user);
      TimeKillEvent(uTimerID);      { kill the timer }
      dwUser2 := 0;                 { reset the timerID for this buffer }
   end;
end;
{------------------------------------------------------------------------}
procedure CopySnd(pDest: PChar; len, rest, cDiff: DWORD; lpft: PMMft);
Label loop;
Var
  bytes: DWORD;
  lpwh : PWaveHdr;
  ms   : Longint;
begin
   with lpft^ do
   begin
loop:
     lpwh := First;
     if (lpwh <> nil) then
     begin
        with lpwh^ do
        begin
           bytes := dwBufferLength - reserved;
           if (bytes > len) then bytes := len;
           Move((lpData+reserved)^, pDest^, bytes);
           inc(reserved, bytes);
           inc(pDest, bytes);
           dec(len, bytes);
           if (reserved >= dwBufferLength) then
           begin
              First := lpNext;
              if EXACTRETURN or (First = nil) then
              begin
                 ms := MulDiv32(cDiff-(rest+len),1000,DataRate);
                 if Emulated then inc(ms,TIMEADJUST);
                 if (ms > 0) then
                 begin
                    PMMWaveHdr(lpwh)^.dwUser1 := DWORD(lpft);
                    PMMWaveHdr(lpwh)^.dwUser2 := TimeSetEvent(ms, 0, @DoneMarker, DWORD(lpwh),TIME_ONESHOT);
                 end;
              end
              else ms := 0;
              if (PMMWaveHdr(lpwh)^.dwUser2 = 0) or (ms <= 0) then
              begin
                 lpwh^.dwFlags := lpwh^.dwFlags or WHDR_DONE;
                 NotifyMessage(lpft, MM_WOM_DONE, DWORD(lpft), DWORD(lpwh));
              end;
              if (len > 0) then goto loop;
           end;
        end;
     end;
     if (len > 0) then
     begin
        FillChar(pDest^, len, SilenceVal);
     end;
   end;
end;
{------------------------------------------------------------------------}
procedure ProcessData(lpft: PMMft);
Var
   cPlay, cWrite, cDiff: DWORD;
   p1, p2: PChar;
   l1, l2: DWORD;
   dwNumToWrite: DWORD;
begin
   EnterCritical;
   with lpft^ do
   if Started and not Paused then
   begin
      if UpdateVolume then
      begin
         lpDSB.SetVolume(Volume);
         UpdateVolume := False;
      end;
      lpDSB.GetCurrentPosition(cPlay, cWrite);
      if (cPlay < LastPlayPos) then
      begin
         if (LastPlayPos-cPlay > 16) then
             cDiff := BufferSize - LastPlayPos + cPlay
         else
         begin
            TotalPlayed := LastPlayPos-cPlay;
            cDiff := 0;
         end;
      end
      else
          cDiff := cPlay - LastPlayPos;
      inc(TotalPlayed,cDiff);
      LastPlayPos := cPlay;
      dwNumToWrite := Min(((BufferSize-(TotalWritten-TotalPlayed))div EachTick)*EachTick,EachTick);
      if (dwNumToWrite >= EachTick) then
      begin
         if lpDSB.Lock(NextPos,EachTick,p1,l1,p2,l2,0) = DS_OK then
         begin
            inc(NextPos, EachTick);
            inc(TotalWritten, EachTick);
            { calc the difference between play and write }
            if (NextPos >= cPlay) then
                cDiff := NextPos-cPlay
            else
                cDiff := (BufferSize-cPlay)+NextPos;
            if (p1 <> Nil) then CopySnd(p1,l1,l2,cDiff,lpft);
            if (p2 <> Nil) then CopySnd(p2,l2,0,cDiff,lpft);
            if (NextPos >= BufferSize) then
                dec(NextPos, BufferSize);
            lpDSB.Unlock(p1,l1,p2,l2);
         end;
      end;
   end;
   LeaveCritical;
end;
const
   NoReEnter : DWORD = 0;
{------------------------------------------------------------------------}
procedure TimerFunc(uTimerID, uMessage: UINT; user, dw1, dw2: DWORD); stdcall;
var
   lpft: PMMft;
begin
   inc(NoReEnter);
   if (NoReEnter = 1) then
   begin
      lpft := lpMMft;
      while (lpft <> Nil) do
      begin
         ProcessData(lpft);
         lpft := lpft^.NextMMft;
      end;
   end;
   dec(NoReEnter);
end;
{--- Notifications with a thread ----------------------------------------------}
procedure OleCheck(Result: HResult);
const
  strOleError = 'Ole Error, code = $%s';
{$IFDEF DELPHI3} resourcestring {$ENDIF}
  SOleError = strOleError;
begin
  if Result <> S_OK then
    raise Exception.CreateFmt(SOleError, [IntToHex(Result, 8)]);
end;
const
  NOTIFICATIONTHREAD_TIMEOUT = 10000;
type
  TDSNotificationThread = class(TMMThreadEx)
  protected
    FSystemEvent: THandle;
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;
  end;
var
  DSNotificationThread: TDSNotificationThread;
  DSNotificationThread_RefCount: Integer;
{------------------------------------------------------------------------}
constructor TDSNotificationThread.Create;
begin
   inherited Create(False);
   FSystemEvent := CreateEvent(nil, False, False, nil);
end;
{------------------------------------------------------------------------}
destructor TDSNotificationThread.Destroy;
begin
   CloseHandle(FSystemEvent);
   inherited;
end;
{------------------------------------------------------------------------}
procedure TDSNotificationThread.Execute;
type
    TFtArray = array[0..0] of PMMFt;
    PFtArray = ^TFtArray;
var
   HandleCount: Integer;
   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);
   lphWaveOut^ := 0;
end;
{------------------------------------------------------------------------}
{ Used internally by DSWaveOutWrite, DSWaveOutRestart, DSWaveOutClose    }
function Timer_Addref(lpft: PMMft): HResult;
begin
   Result := S_OK;
   inc(TimerInit);
   if (TimerInit = 1) then
   begin
      TimeBeginPeriod(1);
      TimerID := TimeSetEvent(1000 div TIMERRATE, 0, @TimerFunc, 0, TIME_PERIODIC);
      if TimerID = 0 then
      begin
        lpft^.lpDSB.Stop;
        dec(TimerInit);
        LeaveCritical;
        Result := E_FAIL;
      end;
   end;
end;
{------------------------------------------------------------------------}
procedure Timer_Release;
begin
   if (TimerInit > 0) then
   begin
      dec(TimerInit);
      if (TimerInit = 0) then
      begin
        TimeKillEvent(TimerID);
        TimeEndPeriod(1);
      end;
   end;
end;
{------------------------------------------------------------------------}
function DSWaveOutClose(hWaveOut: HWAVEOUT): MMRESULT;
Label cont,cont2;
var
   lpft,lpft2: PMMFt;
   m: integer;
begin
   EnterCritical;
   Result := 1;
   lpft := lpMMft;
   if (integer(lpft) = hWaveOut) then lpMMft := lpMMft^.NextMMft
   else
   begin
      while (lpft^.NextMMft <> Nil) do
      begin
         if (integer(lpft^.NextMMft) = hWaveOut) then
         begin
            lpft^.NextMMft := lpft^.NextMMft^.NextMMft;
            goto cont;
         end;
         lpft := lpft^.NextMMft;
      end;
      LeaveCritical;
      exit;
   end;
cont:
   DSWaveOutReset(hWaveOut);
   lpft := PMMft(hWaveOut);
   m := -10000;
   lpft^.lpDSB.SetVolume(m);
   lpft^.lpDSB.SetCurrentPosition(0);
   lpft^.lpDSB.Stop;
   if (lpft^.Started) and (lpft^.NtfResources <> AllNtfResources) then
       Timer_Release;
   DoneNotifications(lpft);
   lpft^.lpDSB.Release;
   NotifyMessage(lpft, MM_WOM_CLOSE, Longint(lpft), 0);
   if (lpMMft = Nil) then
   begin
      if (lpft^.lpDSP <> nil) then lpft^.lpDSP.Release;
      if (lpft^.lpDS <> nil) then lpft^.lpDS.Release;
   end
   else
   begin
      lpft2 := lpMMft;
      while lpft2 <> nil do
      begin
         if lpft2^.lpGUID = lpft^.lpGUID then goto cont2;
         lpft2 := lpft2^.NextMMft;
      end;
      if (lpft^.lpDSP <> nil) then lpft^.lpDSP.Release;
      if (lpft^.lpDS <> nil) then lpft^.lpDS.Release;
   end;
cont2:
   LeaveCritical;
   DoneCritical;
   GlobalFreePtr(lpft);
   DSoundHW := 0;
   Result := 0;
end;
{------------------------------------------------------------------------}
function DSWaveOutPrepareHeader(hWaveOut: HWAVEOUT; lpWaveHdr: PWaveHdr;
                                uSize: UINT): MMRESULT;
begin
   lpWaveHdr^.dwFlags := WHDR_PREPARED;
   Result := 0;
end;
{------------------------------------------------------------------------}
function DSWaveOutUnprepareHeader(hWaveOut: HWAVEOUT; lpWaveHdr: PWaveHdr;
                                  uSize: UINT): MMRESULT;
begin
   if (PMMWaveHdr(lpWaveHdr)^.dwUser2 <> 0) then
      TimeKillEvent(PMMWaveHdr(lpWaveHdr)^.dwUser2);
   PMMWaveHdr(lpWaveHdr)^.dwUser2 := 0;
   lpWaveHdr^.dwFlags := WHDR_DONE;
   Result := 0;
end;
{------------------------------------------------------------------------}
function DSWaveOutWrite(hWaveOut: HWAVEOUT; lpWaveHdr: PWaveHdr;
                        uSize: UINT): MMRESULT;
var
   i,m: integer;
   lpft: PMMft;
   lpwh: PWaveHdr;
begin
   EnterCritical;
   Result := 1;
   lpft := PMMFt(hWaveOut);
   lpWaveHdr^.reserved := 0;
   lpWaveHdr^.lpNext := Nil;
   lpWaveHdr^.dwFlags := lpWaveHdr^.dwFlags and not WHDR_DONE;
   if (lpft^.First = Nil) then
   begin
      lpft^.First := lpWaveHdr;
   end
   else
   begin
      lpwh := lpft^.First;
      while (lpwh^.lpNext <> Nil) do lpwh := lpwh^.lpNext;
      lpwh^.lpNext := lpWaveHdr;
   end;
   if (not lpft^.Started) and (not lpft^.Paused) then
   begin
      if (lpft^.NtfResources <> AllNtfResources) and
         (Timer_Addref(lpft) <> S_OK) then exit;
      lpft^.UpdateVolume := True;
      m := -10000;
      lpft^.lpDSB.SetVolume(m);
      lpft^.lpDSB.SetCurrentPosition(0);
      lpft^.Started := True;
      LeaveCritical;
      { pre-fill the SoundBuffer }
      for i := 0 to BUFFER_PRELOAD-1 do ProcessData(lpft);
      lpft^.lpDSB.Play(0,0,DSBPLAY_LOOPING);
      Result := 0;
      exit;
   end;
   LeaveCritical;
   Result := 0;
end;
{------------------------------------------------------------------------}
function DSWaveOutPause(hWaveOut: HWAVEOUT): MMRESULT;
var
   lpft: PMMft;
   m: integer;
begin
   EnterCritical;
   lpft := PMMFt(hWaveOut);
   lpft^.Paused := True;
   lpft^.lpDSB.Stop;
   m :=-10000;
   lpft^.lpDSB.SetVolume(m);
   LeaveCritical;
   Result := 0;
end;
{------------------------------------------------------------------------}
function DSWaveOutRestart(hWaveOut: HWAVEOUT): MMRESULT;
var
   i: integer;
   lpft: PMMft;
begin
   Result := 1;
   lpft := PMMFt(hWaveOut);
   if (lpft = nil) or not lpft^.Paused then exit;
   EnterCritical;
   if (not lpft^.Started) then
       if (lpft^.NtfResources <> AllNtfResources) and
          (Timer_Addref(lpft) <> S_OK) then
           exit;
   lpft^.Paused := False;
   lpft^.lpDSB.SetVolume(lpft^.Volume);
   lpft^.lpDSB.SetCurrentPosition(0);
   lpft^.Started := True;
   LeaveCritical;
   { pre-fill the SoundBuffer }
   for i := 0 to BUFFER_PRELOAD-1 do ProcessData(lpft);
   lpft^.lpDSB.Play(0,0,DSBPLAY_LOOPING);
   Result := 0;
end;
{------------------------------------------------------------------------}
function DSWaveOutReset(hWaveOut: HWAVEOUT): MMRESULT;
Label ResetExit;
var
   p1, p2: PChar;
   l1, l2: DWORD;
   lpft: PMMft;
   lpwh: PWAVEHDR;
   m: integer;
begin
   EnterCritical;
   Result := 0;
   lpft := PMMFt(hWaveOut);
   if (lpft^.Started) and (lpft^.NtfResources <> AllNtfResources) then
       Timer_Release;
   lpft^.Started := False;
   m := -10000;
   lpft^.lpDSB.SetVolume(m);
   lpft^.lpDSB.Stop;
   lpft^.lpDSB.SetCurrentPosition(0);
   lpwh := lpft^.First;
   while (lpwh <> nil) do
   begin
      lpwh^.dwFlags := lpwh^.dwFlags or WHDR_DONE;
       if (PMMWaveHdr(lpwh)^.dwUser2 <> 0) then
          TimeKillEvent(PMMWaveHdr(lpwh)^.dwUser2);
      PMMWaveHdr(lpwh)^.dwUser2 := 0;
      NotifyMessage(lpft, MM_WOM_DONE, Longint(lpft), Longint(lpwh));
      lpwh := lpwh^.lpNext;
   end;
   lpft^.First       := nil;
   lpft^.TotalWritten:= 0;
   lpft^.TotalPlayed := 0;
   lpft^.LastPlayPos := 0;
   lpft^.NextPos     := 0;
   if lpft^.lpDSB.Lock(0, lpft^.BufferSize,p1,l1,p2,l2,0) <> DS_OK then
      goto ResetExit;
   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 ResetExit;
ResetExit:
   LeaveCritical;
end;
{------------------------------------------------------------------------}
function DSWaveOutGetPosition(hWaveOut: HWAVEOUT; lpInfo: PMMTime;
                              uSize: UINT): MMRESULT;
var
   wfx: TWaveFormatEx;
   lpft: PMMft;
   dwPlay,dwWrite: DWORD;
begin
   EnterCritical;
   Result := 1;
   lpft := PMMFt(hWaveOut);
   if (lpft <> nil) and (lpInfo^.wType = Time_Samples) then
   begin
      if lpft^.lpDSB.GetFormat(@wfx, sizeOf(wfx), nil) = DS_OK then
      begin
         lpft^.lpDSB.GetCurrentPosition(dwPlay,dwWrite);
         if (dwPlay < lpft^.LastPlayPos) then
             dwPlay := lpft^.TotalPlayed+(lpft^.BufferSize-lpft^.LastPlayPos+dwPlay)
         else
             dwPlay := lpft^.TotalPlayed+(dwPlay-lpft^.LastPlayPos);
         lpInfo^.Sample := wioBytesToSamples(@wfx,dwPlay);
         Result := 0;
      end;
   end
   else lpInfo^.wType := Time_Samples;
   LeaveCritical;
end;
{------------------------------------------------------------------------}
function DSWaveOutSetVolume(hWaveOut: HWAVEOUT; dwVolume: DWORD): MMRESULT;
var
   lpft: PMMft;
begin
   EnterCritical;
   Result := 1;
   lpft := PMMFt(hWaveOut);
   if lpft^.lpDSB.SetVolume(dwVolume) = DS_OK then
   begin
     lpft^.Volume := dwVolume;
     Result := 0;
   end;
   LeaveCritical;
end;
{------------------------------------------------------------------------}
function DSWaveOutGetVolume(hWaveOut: HWAVEOUT; lpdwVolume: PDWORD): MMRESULT;
var
   lpft: PMMft;
begin
   EnterCritical;
   Result := 1;
   lpft := PMMFt(hWaveOut);
   if lpft^.lpDSB.GetVolume(lpdwVolume^) = DS_OK then Result := 0;
   LeaveCritical;
end;
{------------------------------------------------------------------------}
function DSWaveOutSetPan(hWaveOut: HWAVEOUT; dwPan: DWORD): MMRESULT;
var
   lpft: PMMft;
begin
   EnterCritical;
   Result := 1;
   lpft := PMMFt(hWaveOut);
   if lpft^.lpDSB.SetPan(dwPan) = DS_OK then Result := 0;
   LeaveCritical;
end;
{------------------------------------------------------------------------}
function DSWaveOutGetPan(hWaveOut: HWAVEOUT; lpdwPan: PDWORD): MMRESULT;
var
   lpft: PMMft;
begin
   EnterCritical;
   Result := 1;
   lpft := PMMFt(hWaveOut);
   if lpft^.lpDSB.GetPan(lpdwPan^) = DS_OK then Result := 0;
   LeaveCritical;
end;
{------------------------------------------------------------------------}
function DSWaveOutSetPlaybackRate(hWaveOut: HWAVEOUT; dwRate: DWORD): MMRESULT;
var
   lpft: PMMft;
begin
   EnterCritical;
   Result := 1;
   lpft := PMMFt(hWaveOut);
   if lpft^.lpDSB.SetFrequency(dwRate) = DS_OK then Result := 0;
   LeaveCritical;
end;
{------------------------------------------------------------------------}
function DSWaveOutGetPlaybackRate(hWaveOut: HWAVEOUT; lpdwRate: PDWORD): MMRESULT;
var
   lpft: PMMft;
begin
   EnterCritical;
   Result := 1;
   lpft := PMMFt(hWaveOut);
   if lpft^.lpDSB.GetFrequency(lpdwRate^) = DS_OK then Result := 0;
   LeaveCritical;
end;
end.

						