source: trunk/Sound.pas

unit Sound;

interface

uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, FileUtil
  {$IFDEF WINDOWS}, mmsystem{$ELSE}, AsyncProcess2, Process{$ENDIF};

type
  TPlayStyle = (psAsync, psSync);

  TSound = class(TComponent)
  private
    {$IFNDEF WINDOWS}
    AsyncProcess: TAsyncProcess;
    SyncProcess: TProcess;
    {$ENDIF}
    FPlayCommand: string;
    FDefaultPlayCommand: string;
    FFileName: string;
    FStyle: TPlayStyle;
  protected
    function GetPlayCommand: string;
    procedure PlaySound(const FileName: string); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Play;
    procedure StopSound;
  published
    property FileName: string read FFileName write FFileName;
    property Style: TPlayStyle read FStyle write FStyle default psASync;
    property PlayCommand: string read FPlayCommand write FPlayCommand;
  end;

procedure Register;


implementation

resourcestring
  SUnableToPlay = 'Unable to play ';
  {$IFDEF WINDOWS}
  {$ELSE}
  SPlayNotSupported = 'The play command %s does not work on your system';
  {$ENDIF}

procedure Register;
begin
  RegisterComponents('Common', [TSound]);
end;

function GetNonWindowsPlayCommand: string;
begin
  Result := '';
  if FindDefaultExecutablePath('ffplay') <> '' then
    Result := 'ffplay -autoexit -nodisp -loglevel quiet'
  else if FindDefaultExecutablePath('play') <> '' then
    Result := 'play -q'
  else if FindDefaultExecutablePath('aplay') <> '' then
    Result := 'aplay -q'
  else if FindDefaultExecutablePath('paplay') <> '' then
    Result := 'paplay'
  else if FindDefaultExecutablePath('mplayer') <> '' then
    Result := 'mplayer -really-quiet'
  else if FindDefaultExecutablePath('CMus') <> '' then
    Result := 'CMus'
  else if FindDefaultExecutablePath('pacat') <> '' then
    Result := 'pacat -p'
  else if FindDefaultExecutablePath('cvlc') <> '' then
    Result := 'cvlc -q --play-and-exit'
  else if FindDefaultExecutablePath('canberra-gtk-play') <> '' then
    Result := 'canberra-gtk-play -c never -f'
  else if FindDefaultExecutablePath('afplay') <> '' then
    Result := 'afplay'
  else if FindDefaultExecutablePath('mpg321') <> '' then
    Result := 'mpg321 -q';
end;

constructor TSound.Create(AOwner: TComponent);
begin
  inherited;
  FStyle := psAsync;
  {$IFDEF WINDOWS}
  FDefaultPlayCommand := 'sndPlaySound';
  {$ELSE}
  FDefaultPlayCommand := GetNonWindowsPlayCommand; // Linux, Mac etc.
  {$ENDIF}
  if FDefaultPlayCommand <> '' then FPlayCommand := FDefaultPlayCommand;
end;

destructor TSound.Destroy;
begin
  {$IFNDEF WINDOWS}
  FreeAndNil(SyncProcess);
  FreeAndNil(AsyncProcess);
  {$ENDIF}
  inherited;
end;

procedure TSound.Play;
begin
  if not FileExists(FFileName) then
    Exit;
  try
    PlaySound(FFileName);
  except
    on E: Exception do
       E.CreateFmt(SUnableToPlay + '%s Message:%s', [FFileName, E.Message]);
  end;
end;

function TSound.GetPlayCommand: String;
begin
  if FPlayCommand = '' then
    Result := FDefaultPlayCommand
  else
    Result := FPlayCommand;
end;

procedure TSound.PlaySound(const FileName: string);
var
{$IFDEF WINDOWS}
  Flags: Word;
{$ELSE}
  CommandParts: TStrings;
  PlayCommand: string;
{$ENDIF}
begin
{$IFDEF WINDOWS}
  if FStyle = psASync then
    Flags := SND_ASYNC or SND_NODEFAULT
  else
    Flags := SND_SYNC or SND_NODEFAULT;
  try
    sndPlaySound(PChar(FileName), Flags);
  except
    ShowMessage(SUnableToPlay + FileName);
  end;
{$ELSE}
  // How to play in Linux? Use generic Linux commands
  // Use asyncprocess to play sound as SND_ASYNC
  // proceed if we managed to find a valid command
  PlayCommand := GetPlayCommand;
  if PlayCommand <> '' then begin
    CommandParts := TStringList.Create;
    try
      CommandParts.Delimiter := ' ';
      CommandParts.DelimitedText := PlayCommand;
      if FStyle = psASync then begin
        if AsyncProcess = nil then
          AsyncProcess := TAsyncProcess.Create(nil);
        AsyncProcess.CurrentDirectory := ExtractFileDir(FileName);
        AsyncProcess.Executable := FindDefaultExecutablePath(CommandParts[0]);
        CommandParts.Delete(0);
        AsyncProcess.Parameters.Clear;
        AsyncProcess.Parameters.AddStrings(CommandParts);
        AsyncProcess.Parameters.Add(FileName);
        try
          AsyncProcess.Execute;
        except
          On E: Exception do
            E.CreateFmt('Playstyle=paASync: ' + SUnableToPlay +
              '%s Message:%s', [FileName, E.Message]);
        end;
      end else begin
        if SyncProcess = nil then
          SyncProcess := TProcess.Create(nil);
        SyncProcess.CurrentDirectory := ExtractFileDir(FileName);
        SyncProcess.Executable := FindDefaultExecutablePath(CommandParts[0]);
        CommandParts.Delete(0);
        SyncProcess.Parameters.Clear;
        SyncProcess.Parameters.AddStrings(CommandParts);
        SyncProcess.Parameters.Add(FileName);
        try
          SyncProcess.Execute;
          SyncProcess.WaitOnExit;
        except
          On E: Exception do
            E.CreateFmt('Playstyle=paSync: ' + SUnableToPlay +
              '%s Message:%s', [FileName, E.Message]);
        end;
      end;
    finally
      FreeAndNil(CommandParts);
    end;
  end
  else
    raise Exception.CreateFmt(SPlayNotSupported, [FPlayCommand]);
{$ENDIF}
end;

procedure TSound.StopSound;
begin
{$IFDEF WINDOWS}
  sndPlaySound(nil, 0);
{$ELSE}
  if SyncProcess <> nil then SyncProcess.Terminate(1);
  if AsyncProcess <> nil then AsyncProcess.Terminate(1);
{$ENDIF}
end;

end.