vraudio.pas

作工控的好控件

{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}

unit VrAudio;

{$I VRLIB.INC}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VrControls;

type
  TVrAudioData = class(TPersistent)
  private
    FSize: Integer;
    FData: Pointer;
    procedure SetSize(Value: Integer);
    procedure WriteStream(Stream: TStream; WriteSize: Boolean); virtual;
    procedure LoadStream(Stream: TStream; ReadSize: Boolean); virtual;
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function Empty: Boolean;
    procedure Clear; virtual;
    procedure LoadFromStream(Stream: TStream); virtual;
    procedure SaveToStream(Stream: TStream); virtual;
    procedure LoadFromFile(const FileName: string); virtual;
    procedure SaveToFile(const FileName: string); virtual;
    property Size: Integer read FSize write SetSize;
    property Data: Pointer read FData;
  end;

  TVrWaveOption = (vwoAsync, vwoNoDefault, vwoLoop, vwoNoStop, vwoNoWait);
  TVrWaveOptions = set of TVrWaveOption;

  TVrWave = class(TVrComponent)
  private
    FSound: TVrAudioData;
    FFlags: Integer;
    FOptions: TVrWaveOptions;
    procedure SetSound(Value: TVrAudioData);
    procedure SetOptions(Value: TVrWaveOptions);
  protected
    procedure UpdatePlayOptions;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Play;
    procedure Stop;
  published
    property Sound: TVrAudioData read FSound write SetSound;
    property Options: TVrWaveOptions read FOptions write SetOptions default [vwoASync, vwoNoDefault];
  end;


implementation

uses
  MMSystem;

const
  AudioId = $99200;

  ufWavePlay: array[TVrWaveOption] of Integer =
    (SND_ASYNC, SND_NODEFAULT, SND_LOOP, SND_NOSTOP, SND_NOWAIT);


{ TVrWave }

constructor TVrWave.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSound := TVrAudioData.Create;
  FOptions := [vwoASync, vwoNoDefault];
  UpdatePlayOptions;
end;

destructor TVrWave.Destroy;
begin
  FSound.Free;
  inherited Destroy;
end;

procedure TVrWave.Play;
var
  OldCursor: TCursor;
begin
  if not Sound.Empty then
  begin
    OldCursor := Screen.Cursor;
    try
      Screen.Cursor := crHourGlass;
      PlaySound(FSound.Data, 0, FFlags);
    finally
      Screen.Cursor := OldCursor;
    end;
  end;
end;

procedure TVrWave.Stop;
begin
  PlaySound(nil, 0, FFlags);
end;

procedure TVrWave.UpdatePlayOptions;
var
  I: TVrWaveOption;
begin
  FFlags := SND_MEMORY;
  for I := Low(TVrWaveOption) to High(TVrWaveOption) do
    if I in Options then FFlags := FFlags or ufWavePlay[I];
  if not (vwoAsync in Options) then
    FFlags := FFlags or SND_SYNC;
end;

procedure TVrWave.SetSound(Value: TVrAudioData);
begin
  FSound.Assign(Value);
end;

procedure TVrWave.SetOptions(Value: TVrWaveOptions);
begin
  if FOptions <> Value then
  begin
    FOptions := Value;
    UpdatePlayOptions;
  end;
end;

{ TVrRawData }

destructor TVrAudioData.Destroy;
begin
  SetSize(0);
  inherited Destroy;
end;

function TVrAudioData.Empty: Boolean;
begin
  Result := FSize = 0;
end;

procedure TVrAudioData.Clear;
begin
  SetSize(0);
end;

procedure TVrAudioData.SetSize(Value: Integer);
begin
  if FSize <> Value then
  begin
    Reallocmem(FData, Value);
    FSize := Value;
  end;
end;

procedure TVrAudioData.DefineProperties(Filer: TFiler);
begin
  Filer.DefineBinaryProperty('Audio', LoadFromStream, SaveToStream, not Empty);
end;

procedure TVrAudioData.Assign(Source: TPersistent);
begin
  if (Source is TVrAudioData) then
  begin
    SetSize(TVrAudioData(Source).Size);
    Move(TVrAudioData(Source).Data^, FData^, Size);
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TVrAudioData.WriteStream(Stream: TStream; WriteSize: Boolean);
var
  Id: Integer;
begin
  if not Empty then
  begin
    if WriteSize then
    begin
      Id := AudioId;
      Stream.Write(Id, Sizeof(Integer));
      Stream.Write(FSize, Sizeof(Integer));
    end;
    Stream.Write(FData^, FSize);
  end;
end;

procedure TVrAudioData.LoadStream(Stream: TStream; ReadSize: Boolean);
var
  Id: Integer;
  NewSize: Integer;
begin
  NewSize := Stream.Size;
  if ReadSize then
  begin
    Stream.Read(Id, Sizeof(Integer));
    if AudioId <> Id then
      raise Exception.Create('Unknown audio streaming format.');
    Stream.Read(NewSize, Sizeof(Integer));
  end;
  SetSize(NewSize);
  Stream.Read(FData^, FSize);
end;

procedure TVrAudioData.LoadFromStream(Stream: TStream);
begin
  LoadStream(Stream, True);
end;

procedure TVrAudioData.SaveToStream(Stream: TStream);
begin
  WriteStream(Stream, True);
end;

procedure TVrAudioData.LoadFromFile(const FileName: string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadStream(Stream, false);
  finally
    Stream.Free;
  end;
end;

procedure TVrAudioData.SaveToFile(const FileName: string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    WriteStream(Stream, false);
  finally
    Stream.Free;
  end;
end;



end.