tvplanit: Add unit "sound.pas" for playing sound on non-Windows systems.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5007 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/tvplanit/examples/fulldemo/demo.lpi

@@ -42,7 +42,7 @@
         <PackageName Value="LCL"/>
       </Item3>
     </RequiredPackages>
-    <Units Count="2">
+    <Units Count="3">
       <Unit0>
         <Filename Value="demo.lpr"/>
         <IsPartOfProject Value="True"/>
@@ -55,6 +55,10 @@
         <ResourceBaseClass Value="Form"/>
         <UnitName Value="demoMain"/>
       </Unit1>
+      <Unit2>
+        <Filename Value="sound.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit2>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

components/tvplanit/examples/fulldemo/demomain.lfm

@@ -784,6 +784,7 @@ object MainForm: TMainForm
     CategoryColorMap.Category9.Description = 'Category 9'
     EnableEventTimer = True
     PlayEventSounds = True
+    OnPlaySound = VpBufDSDataStore1PlaySound
     AutoConnect = True
     AutoCreate = True
     Directory = 'data'

components/tvplanit/examples/fulldemo/demomain.pas

@@ -8,7 +8,7 @@ uses
   Classes, SysUtils, FileUtil, PrintersDlgs, Forms, Controls, Graphics, Dialogs,
   ExtCtrls, StdCtrls, ComCtrls, LCLTranslator, Menus, VpBaseDS, VpDayView,
   VpWeekView, VpTaskList, VpAbout, VpContactGrid, VpMonthView, VpResEditDlg,
-  VpContactButtons, VpBufDS, VpNavBar, VpData, VpPrtPrvDlg, VpPrtFmtDlg, Types;
+  VpContactButtons, VpBufDS, VpNavBar, VpData, VpPrtPrvDlg, VpPrtFmtDlg, Types, VpBase;
 
 type
 
@@ -100,6 +100,8 @@ type
     procedure MnuSettingsClick(Sender: TObject);
     procedure RbAllTasksChange(Sender: TObject);
     procedure RbHideCompletedTasksChange(Sender: TObject);
+    procedure VpBufDSDataStore1PlaySound(Sender: TObject;
+      const AWavFile: String; AMode: TVpPlaySoundMode);
     procedure VpNavBar1ItemClick(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; Index: Integer);
   private
@@ -140,7 +142,8 @@ uses
  {$ENDIF}
   LCLVersion, LResources, LazFileUtils, LazUTF8, StrUtils, DateUtils, Translations,
   IniFiles, Math, Printers,
-  VpMisc, VpBase, VpPrtFmt;
+  VpMisc, VpPrtFmt,
+  sound;
 
 {$UNDEF UTF8_CALLS}
 {$IFDEF LCL}
@@ -872,6 +875,12 @@ begin
   ImageList1.GetBitmap(1, Img.Picture.Bitmap);
 end;
 
+procedure TMainForm.VpBufDSDataStore1PlaySound(Sender: TObject;
+  const AWavFile: String; AMode: TVpPlaySoundMode);
+begin
+  sound.PlaySound(AWavFile, AMode);
+end;
+
 procedure TMainForm.ShowContacts;
 begin
   Notebook.PageIndex := 2;

components/tvplanit/examples/fulldemo/sound.pas

@@ -0,0 +1,181 @@
+{ This unit enables playing of sound for
+  - all versions of Windows
+  - most versions of Linux
+  - maybe Macintosh OSX
+  Adapted from PlayWavePackage by Gordon Bamber.
+  https://sourceforge.net/p/lazarus-ccr/svn/HEAD/tree/components/playsoundpackage/
+}
+
+unit sound;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, VpBase;
+
+procedure PlaySound(const ASoundFilename: string; APlaySoundMode: TVpPlaySoundMode);
+
+
+implementation
+
+uses
+{$IFDEF WINDOWS}
+  mmsystem,
+{$ELSE}
+  process, asyncprocess,
+{$ENDIF}
+  FileUtil;
+
+CONST
+  C_UnableToPlay = 'Unable to play ';
+
+{$IFNDEF WINDOWS}
+var
+  SoundPlayerAsyncProcess: TAsyncProcess = nil;
+  SoundPlayerSyncProcess: TProcess = nil;
+{$ENDIF}
+
+procedure PlaySound(const ASoundFilename: string; APlaySoundMode: TVpPlaySoundMode);
+{$IFNDEF WINDOWS}
+ var
+  playCommand: string;
+  L: TStrings;
+  i: Integer;
+{$ENDIF}
+begin
+{$IFDEF WINDOWS}
+  try
+    case APlaySoundMode of
+      psmAsync : sndPlaySound(PChar(ASoundFilename), SND_ASYNC or SND_NODEFAULT);
+      psmSync  : sndPlaySound(PChar(ASoundFilename), SND_SYNC or SND_NODEFAULT);
+      psmStop  : sndPlaySound(nil, 0);
+    end;
+  except
+    On E: Exception do
+      E.CreateFmt(C_UnableToPlay +
+      '%s Message:%s', [ASoundFilename, E.Message]);
+  end;
+{$ELSE}
+  if (APlaySoundMode = psmStop) then begin
+    if SoundPlayerAsyncProcess <> nil then
+      SoundPlayerAsyncProcess.Terminate(1);
+    exit;
+  end;
+
+  // How to play in Linux? Use generic Linux commands
+  // Use asyncprocess to play sound as SND_ASYNC
+  // Try play
+  playCommand := '';
+  if (FindDefaultExecutablePath('play') <> '') then
+    playCommand := 'play';
+  // Try aplay
+  if (playCommand = '') then
+    if (FindDefaultExecutablePath('aplay') <> '') then
+      playCommand := 'aplay -q ';
+  // Try paplay
+  if (playCommand = '') then
+    if (FindDefaultExecutablePath('paplay') <> '') then
+      playCommand := 'paplay';
+  // Try mplayer
+  if (playCommand = '') then
+    if (FindDefaultExecutablePath('mplayer') <> '') then
+      playCommand := 'mplayer -really-quiet ';
+  // Try CMus
+  if (playCommand = '') then
+    if (FindDefaultExecutablePath('CMus') <> '') then
+      playCommand := 'CMus ';
+  // Try pacat
+  if (playCommand = '') then
+    if (FindDefaultExecutablePath('pacat') <> '') then
+      playCommand := 'pacat -p ';
+  // Try ffplay
+  if (playCommand = '') then
+    if (FindDefaultExecutablePath('ffplay') <> '') then
+      playCommand := 'ffplay -autoexit -nodisp ';
+  // Try cvlc
+  if (playCommand = '') then
+    if (FindDefaultExecutablePath('cvlc') <> '') then
+      playCommand := 'cvlc -q --play-and-exit ';
+  // Try canberra-gtk-play
+  if (playCommand = '') then
+    if (FindDefaultExecutablePath('canberra-gtk-play') <> '') then
+      playCommand := 'canberra-gtk-play -c never -f ';
+  // Try Macintosh command?
+  if (playCommand = '') then
+    if (FindDefaultExecutablePath('afplay') <> '') then
+      playCommand := 'afplay';
+
+  // proceed if we managed to find a valid command
+  if (playCommand <> '') then
+  begin
+    // Since the playcommand found above can contain parameters we must
+    // separate executable and parameters.
+    L := TStringList.Create;
+    try
+      L.Delimiter := ' ';;
+      L.DelimitedText := playCommand;
+      if APlaySoundMode = psmAsync then
+      begin
+        if SoundPlayerAsyncProcess = nil then
+          SoundPlayerAsyncProcess := TAsyncProcess.Create(nil);
+        SoundPlayerAsyncProcess.CurrentDirectory := ExtractFileDir(ASoundFilename);
+        SoundPlayerAsyncProcess.Executable := FindDefaultExecutablePath(L[0]);
+        SoundPlayerAsyncProcess.Parameters.Clear;
+        for i:=1 to L.Count-1 do
+          SoundPlayerAsyncProcess.Parameters.Add(L[i]);
+        SoundPlayerAsyncProcess.Parameters.Add(ASoundFilename);
+
+        WriteLn;
+        WriteLn(SoundPlayerAsyncProcess.Executable);;
+        for i:=0 to SoundPlayerAsyncProcess.Parameters.Count-1 do
+          WriteLn(i, ': ', SoundPlayerAsyncProcess.Parameters[i]);
+        try
+          SoundPlayerAsyncProcess.Execute;
+        except
+          on E: Exception do
+            E.CreateFmt('PlaySoundMode = psmAsync: ' + C_UnableToPlay +
+              '%s Message:%s', [ASoundFilename, E.Message]);
+        end;
+      end
+      else
+      begin
+        if SoundPlayerSyncProcess = nil then
+          SoundPlayerSyncProcess := TProcess.Create(nil);
+        SoundPlayerSyncProcess.CurrentDirectory := ExtractFileDir(ASoundFilename);
+        SoundPlayerSyncProcess.Executable := FindDefaultExecutablePath(L[0]);
+        SoundPlayersyncProcess.Parameters.Clear;
+        for i:=1 to L.Count-1 do
+          SoundPlayerSyncProcess.Parameters.Add(L[i]);
+        SoundPlayerSyncProcess.Parameters.Add(ASoundFilename);
+        try
+          SoundPlayerSyncProcess.Execute;
+          SoundPlayersyncProcess.WaitOnExit;
+        except
+          On E: Exception do
+            E.CreateFmt('PlaySoundMode = psmSync: ' + C_UnableToPlay +
+              '%s Message:%s', [ASoundFilename, E.Message]);
+        end;
+      end;
+
+    finally
+      L.Free;
+    end;
+  end
+  else
+    raise Exception.Create('No sound support found on this system.');
+{$ENDIF}
+end;
+
+
+{$IFNDEF WINDOWS}
+initialization
+
+finalization
+  FreeAndNil(SoundPlayerSyncProcess);
+  FreeAndNil(SoundPlayerAsyncProcess);
+{$ENDIF}
+
+end.
+

components/tvplanit/source/vpevnteditdlg.lfm

@@ -1,7 +1,7 @@
 object DlgEventEdit: TDlgEventEdit
-  Left = 417
+  Left = 512
   Height = 433
-  Top = 211
+  Top = 221
   Width = 697
   BorderStyle = bsToolWindow
   Caption = 'Add / Edit Events'