mmpitch.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]              =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.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: 09.09.98 - 12:05:03 $                                        =}
{========================================================================}
unit MMPitch;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    Classes,
    Controls,
    IniFiles,
    MMSystem,
    MMRegs,
    MMObj,
    MMDSPObj,
    MMUtils,
    MMMath,
    MMWaveIO,
    MMPCMSup;

type
   EMMPitchError = class(Exception);

   {-- TMMPitch -------------------------------------------------------------}
   TMMPitch = class(TMMDSPComponent)
   private
      FEnabled       : Boolean;
      FOpen          : Boolean;

      FPitch         : Float;
      FPitchInc      : Longint;
      FWaveHdr       : TMMWaveHdr;
      FRealBufSize   : Longint;
      FBytesRead     : Longint;
      FIncValue      : Longint;
      FMoreBuffers   : Boolean;
      FDone          : Boolean;

      procedure SetEnabled(aValue: Boolean);
      procedure SetPitch(aValue: Float);
      procedure ReadFromInput(lpwh: PWaveHdr; var MoreBuffers: Boolean);

   protected
      procedure SetPWaveFormat(aValue: PWaveFormatEx); override;
      procedure Opened; override;
      procedure Closed; override;
      procedure Started; override;
      procedure Reseting; override;
      procedure BufferReady(lpwh: PWaveHdr); override;
      procedure BufferLoad(lpwh: PWaveHdr; var MoreBuffers: Boolean); override;

   public
      constructor Create(aOwner: TComponent); override;
      destructor Destroy; override;

      procedure Open;
      procedure Close;
      procedure Reset;

   published
      property Input;
      property Output;
      property Enabled: Boolean read FEnabled write SetEnabled default True;
      property Pitch: Float read FPitch write SetPitch;
   end;

implementation

{== TMMPitch ============================================================}
constructor TMMPitch.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);

   FEnabled     := True;
   FOpen        := False;
   SetPitch(0.0);
end;

{-- TMMPitch ------------------------------------------------------------}
destructor TMMPitch.Destroy;
begin
   Close;

   inherited Destroy;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.SetEnabled(aValue: Boolean);
begin
   if (aValue <> FEnabled) then
   begin
      FEnabled := aValue;
      if FEnabled then Reset;
   end;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.SetPitch(aValue: Float);
begin
   FPitch := MinMaxR(aValue,-50.0,+50.0);
   FPitchInc := Trunc((FPitch+50)*65536/100+32768);
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.SetPWaveFormat(aValue: PWaveFormatEx);
begin
   if (aValue <> nil) then
   begin
      if not (csDesigning in ComponentState) then
         if not pcmIsValidFormat(aValue) then
            raise EMMPitchError.Create(LoadResStr(IDS_INVALIDFORMAT));
   end;
   inherited SetPWaveFormat(aValue);
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.Open;
begin
   if not FOpen then
   begin
      FRealBufSize := Max(BufferSize,Max(QUEUE_READ_SIZE,BufferSize));
      FWaveHdr.wh.dwBufferLength := FRealBufSize;
      FWaveHdr.wh.lpData := GlobalAllocMem(2*FWaveHdr.wh.dwBufferLength);
      FOpen := True;
   end;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.Close;
begin
   if FOpen then
   begin
      FOpen := False;
      GlobalFreeMem(Pointer(FWaveHdr.wh.lpData));
   end;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.Reset;
begin
   if FOpen then
   begin
      FWaveHdr.wh.dwBytesRecorded := 0;
      FWaveHdr.LoopRec.dwLooping := False;
      FBytesRead := 0;
      FIncValue  := 0;
      FDone      := False;
   end;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.Opened;
begin
   Open;

   inherited Opened;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.Closed;
begin
   Close;

   inherited Closed;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.Reseting;
begin
   Reset;

   inherited Reseting;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.Started;
begin
   Reset;

   inherited Started;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.ReadFromInput(lpwh: PWaveHdr; var MoreBuffers: Boolean);
Label _Pitch;
var
   nRead,nDstBytes,nSrcBytes: Longint;

begin
   lpwh^.dwBytesRecorded := 0;
   if (Input <> nil) then
   with FWaveHdr.wh do
   begin
      nDstBytes := lpwh^.dwBufferlength;
      nRead := 0;
_Pitch:
      nSrcBytes := dwBytesRecorded - FBytesRead;
      if (nSrcBytes > 0) then
      begin
         inc(nRead,pcmPitchChange(PWaveFormat, FWaveHdr.wh.lpData+FBytesRead, lpwh^.lpData+nRead,
                                  nSrcBytes, nDstBytes, FIncValue, FPitchInc));

         FBytesRead := dwBytesRecorded - nSrcBytes;
      end;

      { do we need more data ? }
      if (nDstBytes > 0) and not FDone then
      begin
         dwBytesRecorded := 0;

         if FWaveHdr.LoopRec.dwLooping then
         begin
            PMMWaveHdr(lpwh)^.LoopRec.dwLooping := True;
            PMMWaveHdr(lpwh)^.LoopRec.dwLoopTmpCnt := FWaveHdr.LoopRec.dwLoopTmpCnt;
            FWaveHdr.LoopRec.dwLooping := False;
         end;

         FWaveHdr.LoopRec.dwLoop := PMMWaveHdr(lpwh)^.LoopRec.dwLoop;
         if FWaveHdr.LoopRec.dwLoop then
         begin
            FWaveHdr.LoopRec.dwLoopCnt    := PMMWaveHdr(lpwh)^.LoopRec.dwLoopCnt;
            FWaveHdr.LoopRec.dwLoopTmpCnt := PMMWaveHdr(lpwh)^.LoopRec.dwLoopTmpCnt;
            FWaveHdr.LoopRec.dwLooping    := False;
         end;

         FMoreBuffers := False;
         inherited BufferLoad(@FWaveHdr,FMoreBuffers);

         if not FMoreBuffers or (dwBytesRecorded <= 0) then FDone := True;

         FBytesRead := 0;

         if (dwBytesRecorded > 0) then goto _Pitch;
      end;
      MoreBuffers := FMoreBuffers or (dwBytesRecorded-FBytesRead > 0);
      lpwh^.dwBytesRecorded := nRead;
   end;
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.BufferReady(lpwh: PWaveHdr);
begin
   if Enabled and FOpen then
   begin
      { TODO: Pitch f黵's schreiben }
   end;
   inherited BufferReady(lpwh);
end;

{-- TMMPitch ------------------------------------------------------------}
procedure TMMPitch.BufferLoad(lpwh: PWaveHdr; var MoreBuffers: Boolean);
begin
   if Enabled and FOpen and ((FPitchInc <> $10000) or (FWaveHdr.wh.dwBytesRecorded - FBytesRead > 0)) then
   begin
      ReadFromInput(lpwh,MoreBuffers);
   end
   else inherited BufferLoad(lpwh, MoreBuffers);
end;

end.