Delphi控件源码

开发平台：
Delphi

MMWRec.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/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: 10.09.98 - 15:54:27 $                                        =}
{========================================================================}
unit MMWRec;
{$I COMPILER.INC}
interface
uses
{$IFDEF WIN32}
  Windows,
{$ELSE}
  WinTypes,
  WinProcs,
{$ENDIF}
  SysUtils,
  Classes,
  Controls,
  Dialogs,
  MMSystem,
  MMRegs,
  MMObj,
  MMDSPobj,
  MMUtils,
  MMWave,
  MMWavIn,
  MMWaveIO,
  MMPCMSup,
  MMACMDlg;
type
    EMMWaveRecorderError = class(Exception);
    {-- TMMWaveRecorer --------------------------------------------------------}
    TMMWaveRecorder = class(TMMDSPComponent)
    private
       FChanging   : Boolean;
       FStartPos   : Longint;
       FOnStart    : TNotifyEvent;
       FOnStop     : TNotifyEvent;
       FOnPause    : TNotifyEvent;
       FOnRestart  : TNotifyEvent;
       FOnChange   : TNotifyEvent;
       FOnData     : TMMBufferEvent;
       procedure SetWave(aValue: TMMWave);
       function  GetWave: TMMWave;
       procedure SetNumBuffers(aValue: integer);
       function  GetNumBuffers: integer;
       procedure SetDeviceID(aValue: TMMDeviceID);
       function  GetDeviceID: TMMDeviceID;
       procedure SetDummyString(aValue: string);
       function  GetProductName: string;
       function  GetInputFormat: string;
       procedure SetInputFormat(aValue: string);
       procedure SetTimeFormat(aValue: TMMTimeFormats);
       function  GetTimeFormat: TMMTimeFormats;
       procedure SetCallBackMode(aValue: TMMCBMode);
       function  GetCallBackMode: TMMCBMode;
       procedure SetPosition(aValue: Longint);
       function  GetPosition: Longint;
       procedure SetMaxRecTime(aValue: Longint);
       function  GetMaxRecTime: Longint;
       procedure SetMode(aValue: TMMMode);
       function  GetMode: TMMMode;
       procedure SetBits(aValue: TMMBits);
       function  GetBits: TMMBits;
       procedure SetRate(aValue: Longint);
       function  GetRate: Longint;
       procedure SetFileName(aValue: TFileName);
       function  GetFileName: TFileName;
       procedure SetOverwrite(aValue: Boolean);
       function  GetOverwrite: Boolean;
       function  GetState: TMMWaveInState;
       procedure DoChange(Sender: TObject);
       procedure DoChanged(Sender: TObject);
       procedure DoClose(Sender: TObject);
       procedure DoStart(Sender: TObject);
       procedure DoStop(Sender: TObject);
       procedure DoPause(Sender: TObject);
       procedure DoRestart(Sender: TObject);
       procedure DoData(Sender: TObject; lpwh: PWaveHdr);
    protected
       FWaveIn   : TMMWaveIn;
       FWaveFile : TMMWaveFile;
       procedure SetPWaveFormat(aValue: PWaveFormatEx); override;
       function  GetBufferSize: Longint; override;
       procedure SetBufferSize(aValue: Longint); override;
       procedure DefineProperties(Filer: TFiler); override;
       procedure ReadData(Stream: TStream); virtual;
       procedure WriteData(Stream: TStream); virtual;
    public
       constructor Create(aOwner: TComponent); override;
       destructor  Destroy; override;
       procedure Recording;
       procedure Stop;
       procedure Pause;
       procedure Restart;
       function  SelectFile: Boolean;
       function  SelectFormat: Boolean;
       procedure SetPCMFormat(Mode: TMMMode; Bits: TMMBits; SampleRate: Longint);
       procedure SaveFormatInRegistry(RootKey: HKEY; Localkey, Field: string);
       procedure LoadFormatFromRegistry(RootKey: HKEY; Localkey, Field: string);
       property  FileName: TFileName read GetFileName write SetFileName stored False;
       property  PWaveFormat;
       property  State: TMMWaveInState read GetState;
       property  Position: Longint read GetPosition write SetPosition;
    published
       property OnStart: TNotifyEvent read FOnStart write FOnStart;
       property OnStop: TNotifyEvent read FOnStop write FOnStop;
       property OnPause: TNotifyEvent read FOnPause write FOnPause;
       property OnRestart: TNotifyEvent read FOnRestart write FOnRestart;
       property OnChange: TNotifyEvent read FOnChange write FOnChange;
       property OnData: TMMBufferEvent read FOnData write FOnData;
       property Output;
       property Wave: TMMWave read GetWave write SetWave;
       property BufferSize: Longint read GetBufferSize write SetBufferSize;
       property NumBuffers: integer read GetNumBuffers write SetNumBuffers;
       property DeviceID: TMMDeviceID read GetDeviceID write SetDeviceID;
       property ProductName: string read GetProductName write SetDummyString stored False;
       property TimeFormat: TMMTimeFormats read GetTimeFormat write SetTimeFormat;
       property CallBackMode: TMMCBMode read GetCallBackMode write SetCallBackMode;
       property MaxRecordTime: Longint read GetMaxRecTime write SetMaxRecTime;
       property Mode: TMMMode read GetMode write SetMode;
       property BitLength: TMMBits read GetBits write SetBits;
       property SampleRate: Longint read GetRate write SetRate;
       property InputFormat: string read GetInputFormat write SetInputFormat stored False;
       property OverwriteExisting: Boolean read GetOverwrite write SetOverwrite;
    end;
implementation
{== MMWaveRecorder ============================================================}
constructor TMMWaveRecorder.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);
   FWaveFile             := TMMWaveFile.Create(Self);
   FWaveFile.Wave.FileMustExist := False;
   FWaveFile.OnChange    := DoChange;
   FWaveFile.OnChanged   := DoChanged;
   FWaveFile.OnClose     := DoClose;
   FWaveIn               := TMMWaveIn.Create(Self);
   FWaveIn.Output        := FWaveFile;
   FWaveIn.OnOpen        := DoStart;
   FWaveIn.OnStop        := DoStop;
   FWaveIn.OnPause       := DoPause;
   FWaveIn.OnRestart     := DoRestart;
   FWaveIn.OnBufferReady := DoData;
   FStartPos             := 0;
   FInputValid           := True;
   FWaveFile.Output      := Self;
   FInputValid           := False;
   FChanging             := False;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
destructor TMMWaveRecorder.Destroy;
begin
   Stop;
   FWaveFile.Free;
   FWaveIn.Free;
   inherited Destroy;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.ReadData(Stream: TStream);
var
   Buf: PChar;
begin
   Buf := GlobalAllocMem(Stream.Size);
   try
      Stream.ReadBuffer(Buf^,Stream.Size);
      FWaveIn.PWaveFormat := Pointer(Buf);
   finally
      GlobalFreeMem(Pointer(Buf));
   end;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.WriteData(Stream: TStream);
begin
   Stream.WriteBuffer(FWaveIn.PWaveFormat^,wioSizeOfWaveFormat(FWaveIn.PWaveFormat));
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.DefineProperties(Filer: TFiler);
begin
   inherited DefineProperties(Filer);
   Filer.DefineBinaryProperty('WaveFormatEx', ReadData, WriteData, (PWaveFormat <> nil) and (PWaveFormat.wFormatTag <> WAVE_FORMAT_PCM));
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetPWaveFormat(aValue: PWaveFormatEx);
var
   Size,Size2: integer;
begin
   if not FChanging then
   begin
      if (aValue <> nil) then
      begin
         if (FWaveIn.PWaveFormat <> nil) then
         begin
            size := wioSizeOfWaveFormat(aValue);
            size2:= wioSizeOfWaveFormat(FWaveIn.PWaveFormat);
            if (Size <> Size2) or not GlobalCmpMem(aValue^,FWaveIn.PWaveFormat^,Size) then
            begin
               FWaveIn.PWaveFormat := aValue;
               exit;
            end;
         end
         else
         begin
            FWaveIn.PWaveFormat := aValue;
            exit;
         end;
      end;
      inherited SetPWaveFormat(aValue);
   end;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetMode(aValue: TMMMode);
begin
   FWaveIn.Mode := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetMode: TMMMode;
begin
   Result := FWaveIn.Mode;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetBits(aValue: TMMBits);
begin
   FWaveIn.BitLength := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetBits: TMMBits;
begin
   Result := FWaveIn.BitLength;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetRate(aValue: Longint);
begin
   FWaveIn.SampleRate:= aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetRate: Longint;
begin
   Result := FWaveIn.SampleRate;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetWave(aValue: TMMWave);
begin
   FWaveFile.Wave := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetWave: TMMWave;
begin
   Result := FWaveFile.Wave;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.SelectFormat: Boolean;
var
   ACM: TMMACM;
begin
   ACM := TMMACM.Create(nil);
   try
      ACM.EnumFormats := efInput;
      Result := ACM.ChooseFormat(PWaveFormat,'Select Format');
      if Result then
         PWaveFormat := ACM.PWaveFormat;
   finally
      ACM.Free;
   end;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetPCMFormat(Mode: TMMMode; Bits: TMMBits; SampleRate: Longint);
var
   wfx: TWaveFormatEx;
begin
   pcmBuildWaveHeader(@wfx, (Ord(Bits)+1)*8, Ord(Mode)+1, SampleRate);
   PWaveFormat := @wfx;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.SelectFile: Boolean;
begin
   with TSaveDialog.Create(nil) do
   try
      Filter   := 'Wave Files (*.wav)|*.wav|';
      FileName := Self.FileName;
      Options  := Options + [ofPathMustExist, ofFileMustExist, ofHideReadOnly];
      Title    := LoadResStr(IDS_SELECTFILE);
      Result   := Execute;
      if Result then
         Self.FileName := FileName;
   finally
      Free;
   end;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SaveFormatInRegistry(RootKey: HKEY; Localkey, Field: string);
begin
   SaveInRegistryBinary(RootKey,LocalKey,Field,PWaveFormat^,wioSizeOfWaveFormat(PWaveFormat));
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.LoadFormatFromRegistry(RootKey: HKEY; Localkey, Field: string);
var
   wfx: array[0..1024] of Char;
begin
   if GetFromRegistryBinary(RootKey,LocalKey,Field,wfx,sizeOf(wfx)) > 0 then
      PWaveFormat := @wfx;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetFileName(aValue: TFileName);
begin
   FWaveFile.Wave.FileName := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetFileName: TFileName;
begin
   Result := FWaveFile.Wave.FileName;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetBufferSize(aValue: Longint);
begin
   FWaveIn.BufferSize := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetBufferSize: Longint;
begin
   Result := FWaveIn.BufferSize;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetNumBuffers(aValue: integer);
begin
   FWaveIn.NumBuffers := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetNumBuffers: integer;
begin
   Result := FWaveIn.NumBuffers;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetDeviceID(aValue: TMMDeviceID);
begin
   FWaveIn.DeviceID := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetDeviceID: TMMDeviceID;
begin
   Result := FWaveIn.DeviceID;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetDummyString(aValue: string);
begin
   ;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetProductName: string;
begin
   Result := FWaveIn.ProductName;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetInputFormat: string;
var
   FormatTag, Format: string;
begin
   Result := 'Unknown';
   if acmGetFormatDescription(FWaveIn.PWaveFormat, FormatTag, Format) then
      Result := FormatTag+' '+Format;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetInputFormat(aValue: string);
begin
   MessageDlg('This is a read-only property, please use SelectFormat.',
              mtInformation,[mbOK],0);
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetTimeFormat(aValue: TMMTimeFormats);
begin
   FWaveIn.TimeFormat  := aValue;
   FWaveFile.Wave.TimeFormat := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetTimeFormat: TMMTimeFormats;
begin
   Result := FWaveIn.TimeFormat;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetCallBackMode(aValue: TMMCBMode);
begin
   FWaveIn.CallBackMode := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetCallBackMode: TMMCBMode;
begin
   Result := FWaveIn.CallBackMode;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetMaxRecTime(aValue: Longint);
begin
   FWaveIn.MaxRecordTime := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetMaxRecTime: Longint;
begin
   Result := FWaveIn.MaxRecordTime;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetOverwrite(aValue: Boolean);
begin
   FWaveFile.OverwriteExisting := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetOverwrite: Boolean;
begin
   Result := FWaveFile.OverwriteExisting;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetState: TMMWaveInState;
begin
   Result := FWaveIn.State;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.SetPosition(aValue: Longint);
begin
   if (wisOpen in State) then
       raise EMMWaveRecorderError.Create(LoadResStr(IDS_PROPERTYOPEN));
   if not OverwriteExisting then
      FWaveFile.Wave.Position := aValue;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
function TMMWaveRecorder.GetPosition: Longint;
begin
   if (wisOpen in State) then
   begin
      Result := FWaveIn.Position;
      if not OverwriteExisting then
         inc(Result,FStartPos);
   end
   else if not OverwriteExisting then
      Result := FWaveFile.Wave.Position
   else
      Result := 0;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.DoChange(Sender: TObject);
begin
   FChanging := True;
   Stop;
   if assigned(FOnChange) then FOnChange(Self);
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.DoChanged(Sender: TObject);
begin
   FChanging := False;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.DoClose(Sender: TObject);
begin
   Stop;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.DoStart(Sender: TObject);
begin
   if assigned(FOnStart) then FOnStart(Self);
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.DoStop(Sender: TObject);
begin
   FWaveIn.Close;
   if assigned(FOnStop) then FOnStop(Self);
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.DoPause(Sender: TObject);
begin
   if assigned(FOnPause) then FOnPause(Self);
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.DoRestart(Sender: Tobject);
begin
   if assigned(FOnRestart) then FOnRestart(Self);
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.DoData(Sender: TObject; lpwh: PWaveHdr);
begin
   if assigned(FOnData) then FOnData(Self,lpwh);
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.Recording;
begin
   if not (wisRecord in State) and (FWaveFile.Wave.FileName <> '') then
   begin
      FStartPos := FWaveFile.Wave.Position;
      FWaveIn.Start;
   end;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.Stop;
begin
   FWaveIn.Stop;
   FWaveIn.Close;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.Pause;
begin
   if not (wisPause in State) and (FWaveFile.Wave.FileName <> '') then FWaveIn.Pause;
end;
{-- TMMWaveRecorder -----------------------------------------------------------}
procedure TMMWaveRecorder.Restart;
begin
   FWaveIn.Restart;
end;
end.

						