Initial commit.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3553 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
gbamber
2014-09-12 13:55:50 +00:00
parent 324588fb04
commit 336905292e
20 changed files with 1299 additions and 0 deletions

Binary file not shown.

After

Width:  |  Height:  |  Size: 978 B

View File

@ -0,0 +1,624 @@
{ TAboutPlaySound and TAboutBox Component License
Copyright (C) 2014 Gordon Bamber minesadorada@charcodelvalle.com
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
// Change the name of this unit and its PAS file to be unique to your component
// Unit About<yourcomponentname>unit
unit aboutplaysound;
{$mode objfpc}{$H+}
interface
uses
Classes, Controls, Dialogs, Forms, Graphics, LResources, SysUtils,
ExtCtrls, StdCtrls, StrUtils,Buttons,PropEdits;
const
C_DEFAULTLICENSEFORMWIDTH = 500;
C_DEFAULTLICENSEFORMWIDTH_LINUX = C_DEFAULTLICENSEFORMWIDTH + 100;
C_DEFAULTLICENSEFORMHEIGHT = 400;
C_DEFAULTLICENSEFORMHEIGHT_LINUX = C_DEFAULTLICENSEFORMHEIGHT + 50;
type
TLicenseType = (abNone, abGPL, abLGPL, abMIT, abModifiedGPL, abProprietry);
tAboutBox=Class; // Forward declaration
// Do Search/Replace to change all instances of TAboutComonent
// to TAbout<yourcomponentname>
TAboutPlaySound = class(TComponent)
// This class can descend from any component class (TGraphicControl etc
private
{ Private declarations }
fAboutBox: tAboutBox;
procedure SetMyComponentName(Const Avalue:String);
procedure SetAboutBoxWidth(Const AValue:Integer);
procedure SetAboutBoxHeight(Const AValue:Integer);
procedure SetAboutBoxDescription(Const AValue:String);
procedure SetAboutBoxFontName(Const AValue:String);
procedure SetAboutBoxFontSize(Const AValue:Integer);
procedure SetAboutBoxBitmap(Const AValue:TBitmap);
procedure SetAboutBoxBackgroundColor(Const AValue:TColor);
procedure SetAboutBoxTitle(Const AValue:String);
procedure SetAboutBoxVersion(Const AValue:String);
procedure SetAboutBoxAuthorname(Const AValue:String);
procedure SetAboutBoxOrganisation(Const AValue:String);
procedure SetAboutBoxAuthorEmail(Const AValue:String);
procedure SetAboutBoxBackgroundResourceName(Const AValue:String);
procedure SetAboutBoxLicenseType(Const AValue:String);
procedure SetAboutBoxStretchBackgroundImage(Const AValue:Boolean);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override; // Constructor must be public
destructor Destroy; override; // Destructor must be public
// Set these (hidden) properties in your inherited component's Create procedure
property AboutBoxComponentName:String write SetMyComponentName;
property AboutBoxWidth:Integer write SetAboutBoxWidth;
property AboutBoxHeight:Integer write SetAboutBoxHeight;
property AboutBoxDescription:String write SetAboutBoxDescription;
property AboutBoxFontName:String write SetAboutBoxFontName;
property AboutBoxFontSize:Integer write SetAboutBoxFontSize;
property AboutBoxBackgroundColor:TColor write SetAboutBoxBackgroundColor;
property AboutBoxTitle:String write SetAboutBoxTitle;
property AboutBoxVersion:String write SetAboutBoxVersion;
property AboutBoxAuthorname:String write SetAboutBoxAuthorname;
property AboutBoxOrganisation:String write SetAboutBoxOrganisation;
property AboutBoxAuthorEmail:String write SetAboutBoxAuthorEmail;
property AboutBoxLicenseType:String write SetAboutBoxLicenseType;
property AboutBoxBackgroundResourceName:String write SetAboutBoxBackgroundResourceName;
property AboutBoxStretchBackgroundImage:Boolean write SetAboutBoxStretchBackgroundImage;
published
// The clickable 'About' property will automaticcally appear in any component
// descended from TAboutPlaySound
// About this component...
property About: tAboutBox read fAboutBox write fAboutBox;
end;
TAboutbox = class(TComponent)
private
{ Private declarations }
fDialog: TForm;
fBackgroundbitmap: TBitMap;
fBackgroundResourceName:String;
fDescription: TStrings;
fDialogTitle, fVersion, fAuthorname, fAuthorEmail, fOrganisation,
fComponentName: string;
fDialogHeight, fDialogWidth: integer;
fStretchBackground: boolean;
fFont: TFont;
fColor: TColor;
fLicenseType: TLicenseType;
procedure SetBackgroundBitmap(const AValue: TBitMap);
procedure SetDescriptionStrings(const AValue: TStrings);
procedure SetFont(const AValue: TFont);
procedure ShowLicense(Sender: TObject);
procedure SetDialogTitle(Const AValue:String);
protected
{ Protected declarations }
public
{ Public declarations }
procedure ShowDialog;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
// Set these properties in your component Constructor method
property BackGround: TBitMap read fBackgroundbitmap write SetBackgroundBitmap;
property BackgroundResourceName:String read fBackgroundResourceName write fBackgroundResourceName;
property Description: TStrings read fDescription write SetDescriptionStrings;
property Title: string read fDialogTitle write SetDialogTitle;
property Height: integer read fDialogHeight write fDialogHeight;
property Width: integer read fDialogWidth write fDialogWidth;
property Font: TFont read fFont write SetFont;
property BackGroundColor: TColor read fColor write fColor;
property StretchBackground: boolean read fStretchBackground
write fStretchBackground default False;
property Version: string read fVersion write fVersion;
property Authorname: string read fAuthorname write fAuthorname;
property Organisation: string read fOrganisation write fOrganisation;
property AuthorEmail: string read fAuthorEmail write fAuthorEmail;
property ComponentName: string read fComponentName write fComponentName;
property LicenseType: TLicenseType read fLicenseType write fLicenseType;
end;
// Declaration for the 'About' property editor
TAboutPropertyEditor = class(TClassPropertyEditor)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
end;
procedure Register;
{For i8n if required}
resourcestring
rs_Componentname='Component name';
rs_About='About';
rs_License='License';
rs_By='By';
rs_For='For';
rs_DatafileMissing='Resource datafile license.lrs is missing';
rs_LicenseTextError='There is something wrong with the Licence text';
rs_AboutBoxError = 'Subcomponent TAboutBox Error';
implementation
{ TABoutBox}
constructor TAboutbox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fBackgroundbitmap := TBitMap.Create;
fDescription := TStringList.Create;
fFont := TFont.Create;
fColor := clDefault;
fLicenseType := abNone;
fComponentName:=rs_Componentname;
fDialogTitle:=rs_About + ' ' + fComponentName;
fDialogWidth:=320;
fDialogHeight:=280;
fVersion:='1.0.0.0';
fLicenseType:=abNone;
end;
destructor TAboutbox.Destroy;
begin
FreeAndNil(fFont);
FreeAndNil(fDescription);
FreeAndNil(fBackgroundbitmap);
inherited Destroy;
end;
procedure TAboutbox.SetDialogTitle(Const AValue:String);
begin
if AnsiContainsText(fDialogTitle, rs_About) then
fDialogTitle := AValue
else
fDialogTitle := rs_About + ' ' + Avalue;
end;
procedure TAboutbox.ShowDialog;
var
OKbutton, LicenseButton: TBitBtn;
lbl_Description: TLabel;
img_BackGround: TImage;
sz: string;
iCount: integer;
r:TLResource;
begin
fDialog := TForm.CreateNew(nil);
try //.. finally FreeAndNil everything
with fDialog do
begin
// Set Dialog properties
position := poScreenCenter;
borderstyle := bsToolWindow;
Caption := fDialogTitle;
formstyle := fsSystemStayOnTop;
color := fColor;
font := fFont;
if (fDialogHeight > 0) then
Height := fDialogHeight
else
Height := 240;
if (fDialogWidth > 0) then
Width := fDialogWidth
else
Width := 320;
// Create a background image
img_BackGround := Timage.Create(fDialog);
with img_BackGround do
// Set img_BackGround properties
begin
Align := alClient;
Stretch := fStretchBackground;
// Bitmap assigned?
if Assigned(fBackgroundbitmap) then
Picture.Assign(fBackgroundbitmap);
// Resource file?
r := LazarusResources.Find(fBackgroundResourceName);
if r <> nil then
img_BackGround.Picture.LoadFromLazarusResource(fBackgroundResourceName);
SendToBack;
parent := fDialog;
end;
// Create a BitBtn button
okbutton := TBitBtn.Create(fDialog);
// Set BitBtn properties
with okButton do
begin
Kind := bkClose;
left := (fDialog.Width div 2) - Width div 2;
top := fDialog.Height - Height - 10;
ParentFont:=False;
parent := fDialog;
end;
// Create a License Button
LicenseButton := TBitBtn.Create(fDialog);
if (fLicenseType <> abNone) then
// Put it on the right
begin
LicenseButton.Top := OKButton.Top;
LicenseButton.Caption := rs_License + '...';
LicenseButton.left := Width - LicenseButton.Width - 10;
LicenseButton.OnClick := @ShowLicense;
LicenseButton.ParentFont:=False;
LicenseButton.Parent := fDialog;
end;
// Create a label control
lbl_Description := Tlabel.Create(fDialog);
// Set label properties
with lbl_Description do
begin
left := 8;
Top := 30;
Width := fDialog.Width - 8;
Height := fDialog.Height - 30;
Autosize := False;
ParentFont := True;
Alignment := taCenter;
end;
// Build up Label text
sz := '';
// Component name
if fComponentName <> '' then
sz += fComponentName + LineEnding;
// Author name (+Email)
if fAuthorname <> '' then
sz += rs_By + ': ' + fAuthorname + LineEnding;
if fAuthorEmail <> '' then
sz += ' (' + fAuthorEmail + ')' + LineEnding
else
sz += LineEnding;
sz += LineEnding;
// Version
if fVersion <> '' then
sz += 'Version: ' + fVersion + LineEnding;
// License
case fLicenseType of
abGPL: sz += rs_License + ': GPL' + LineEnding;
abLGPL: sz += rs_License + ': LGPL' + LineEnding;
abMIT: sz += rs_License + ': M.I.T.' + LineEnding;
abModifiedGPL: sz += rs_License + ': Modified GPL' + LineEnding;
abProprietry: sz += rs_License + ': Proprietry' + LineEnding;
end;
if fOrganisation <> '' then
sz += rs_For + ': ' + fOrganisation + LineEnding;
if fDescription.Count > 0 then
begin
sz += LineEnding;
for iCount := 1 to fDescription.Count do
sz += fDescription[iCount - 1] + LineEnding;
end;
lbl_Description.Caption := sz;
lbl_Description.parent := fDialog;
// Display the dialog modally
ShowModal;
end;
finally
// Free all resources
FreeAndNil(img_BackGround);
FreeAndNil(lbl_Description);
FreeAndNil(LicenseButton);
FreeAndNil(okbutton);
end;
end;
procedure TAboutbox.ShowLicense(Sender: TObject);
// Triggered by License button Click
var
sLicenseString: string;
theList: TStringList;
f: integer;
LicenceForm: TForm;
lblText: TLabel;
closebuttton: TBitBtn;
r: TLResource;
szLicenseFile: string;
begin
// Quit early?
if fLicenseType = abNone then
Exit;
// Set to resource name in license.lrs
case fLicenseType of
abNone: szLicenseFile := '';
abGPL: szLicenseFile := 'gpl.txt';
abLGPL: szLicenseFile := 'lgpl.txt';
abMIT: szLicenseFile := 'mit.txt';
abModifiedgpl: szLicenseFile := 'modifiedgpl.txt';
end;
// Use a string list to split the text file into lines
theList := TStringList.Create;
// Create a window, label and close button on-the-fly
LicenceForm := TForm.Create(nil);
lblText := TLabel.Create(LicenceForm);
closebuttton := TBitBtn.Create(LicenceForm);
// Load up the text into variable 'sLicenseString'
sLicenseString := LineEnding + LineEnding + fComponentName + LineEnding;
try
try
begin
// Load license text from resource string
r := LazarusResources.Find(szLicenseFile);
if r = nil then
raise Exception.Create(rs_DatafileMissing);
thelist.Add(r.Value);
for f := 0 to TheList.Count - 1 do
sLicenseString += TheList[f] + LineEnding;
end;
except
On e: Exception do
MessageDlg(rs_AboutBoxError,
rs_LicenseTextError, mtError, [mbOK], 0);
end;
// Replace boilerplate text if possible
sLicenseString := AnsiReplaceText(sLicenseString, '<year>',
{$I %DATE%}
);
sLicenseString := AnsiReplaceText(sLicenseString, '<name of author>', fAuthorname);
sLicenseString := AnsiReplaceText(sLicenseString, '<contact>',
'(' + fAuthorEmail + ')');
sLicenseString := AnsiReplaceText(sLicenseString, '<copyright holders>',
fOrganisation);
// Make up the form window and controls
with LicenceForm do
begin
// Form
{$IFDEF WINDOWS}
// More compact GUI?
Width := C_DEFAULTLICENSEFORMWIDTH;
Height := C_DEFAULTLICENSEFORMHEIGHT;
{$ELSE WINDOWS}
Width := C_DEFAULTLICENSEFORMWIDTH_LINUX;
Height := C_DEFAULTLICENSEFORMHEIGHT_LINUX;
{$ENDIF}
// autosize:=true;
// If you enable autosize, the button placement goes awry!
// The Modified GPL has an extra clause
if (szLicenseFile = 'modifiedgpl.txt') or
(Pos('As a special exception', sLicenseString) > 0) then
Height := Height + 100;
position := poScreenCenter;
borderstyle := bsToolWindow;
Caption := fComponentName + ': Licensing';
formstyle := fsSystemStayOnTop;
// Label
lblText.Align := alClient;
lblText.Alignment := taCenter;
lblText.Caption := sLicenseString;
lblText.Parent := LicenceForm;
// Close Button
closebuttton.Kind := bkClose;
closebuttton.left := (Width div 2) - closebuttton.Width div 2;
closebuttton.top := Height - closebuttton.Height - 10;
closebuttton.parent := LicenceForm;
// Show modally over the existing modal form
PopupParent := TForm(Sender);
ShowModal;
end;
finally
// Free up all component created resources from memory
FreeAndNil(theList);
FreeAndNil(lblText);
FreeAndNil(closebuttton);
FreeAndNil(LicenceForm);
end;
end;
procedure TAboutbox.SetBackgroundBitmap(const AValue: TBitMap);
begin
if Assigned(AValue) then
fBackgroundbitmap.Assign(AValue);
end;
procedure TAboutbox.SetDescriptionStrings(const AValue: TStrings);
begin
if Assigned(AValue) then
fDescription.Assign(Avalue);
end;
procedure TAboutbox.SetFont(const AValue: TFont);
begin
if Assigned(AValue) then
fFont.Assign(AValue);
end;
{ TAboutPlaySound }
procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TAboutbox),
TAboutPlaySound, 'About', TAboutPropertyEditor);
end;
procedure TAboutPropertyEditor.Edit;
// Communicate with the component properties
Var
AAboutBox:TAboutBox;
begin
AAboutBox:=TAboutBox(GetObjectValue(TAboutBox));
AABoutBox.ShowDialog;
end;
function TAboutPropertyEditor.GetAttributes: TPropertyAttributes;
// Show the ellipsis
begin
Result := [paDialog, paReadOnly];
end;
// Sets for AboutBox dialog properties
procedure TAboutPlaySound.SetMyComponentName(Const Avalue:String);
begin
fAboutBox.ComponentName:=AValue;
fAboutBox.Title:=AValue;
end;
procedure TAboutPlaySound.SetAboutBoxWidth(Const AValue:Integer);
begin
fAboutBox.Width:=Avalue;
end;
procedure TAboutPlaySound.SetAboutBoxHeight(Const AValue:Integer);
begin
fAboutBox.Height:=Avalue;
end;
procedure TAboutPlaySound.SetAboutBoxDescription(Const AValue:String);
begin
fAboutBox.Description.Clear;
fAboutBox.Description.Add(AValue);
end;
procedure TAboutPlaySound.SetAboutBoxFontName(Const AValue:String);
begin
fAboutBox.Font.Name:=AValue;
end;
procedure TAboutPlaySound.SetAboutBoxFontSize(Const AValue:Integer);
begin
if (AValue > 6) then fAboutBox.Font.Size:=AValue;
end;
procedure TAboutPlaySound.SetAboutBoxTitle(Const AValue:String);
begin
fAboutBox.Title:=AValue;
end;
procedure TAboutPlaySound.SetAboutBoxBitmap(Const AValue:TBitmap);
begin
If Assigned(Avalue) then fAboutBox.Assign(AValue);
end;
procedure TAboutPlaySound.SetAboutBoxBackgroundColor(Const AValue:TColor);
begin
fAboutBox.BackGroundColor:=AValue;;
end;
procedure TAboutPlaySound.SetAboutBoxVersion(Const AValue:String);
begin
fAboutBox.Version:=AValue;
end;
procedure TAboutPlaySound.SetAboutBoxAuthorname(Const AValue:String);
begin
fAboutBox.Authorname:=AValue;
end;
procedure TAboutPlaySound.SetAboutBoxOrganisation(Const AValue:String);
begin
fAboutBox.Organisation:=AValue;
end;
procedure TAboutPlaySound.SetAboutBoxAuthorEmail(Const AValue:String);
begin
fAboutBox.AuthorEmail:=AValue;
end;
procedure TAboutPlaySound.SetAboutBoxBackgroundResourceName(Const AValue:String);
begin
fAboutBox.BackgroundResourceName:=AValue;
end;
procedure TAboutPlaySound.SetAboutBoxLicenseType(Const AValue:string);
begin
Case Upcase(AValue) of
'GPL':fAboutBox.LicenseType:=abGPL;
'LGPL':fAboutBox.LicenseType:=abLGPL;
'MIT':fAboutBox.LicenseType:=abMIT;
'MODIFIEDGPL':fAboutBox.LicenseType:=abModifiedGPL;
'PROPRIETRY':fAboutBox.LicenseType:=abProprietry;
else
fAboutBox.LicenseType:=abNone;
end;
end;
procedure TAboutPlaySound.SetAboutBoxStretchBackgroundImage(Const AValue:Boolean);
begin
fAboutBox.StretchBackground:=AValue;
end;
// End Sets
constructor TAboutPlaySound.Create(AOwner: TComponent);
var
TempImage: TPicture;
r:TLResource;
begin
// Inherit default properties
inherited Create(AOwner);
// Use tAboutBox as a subcomponent
fAboutBox := tAboutBox.Create(nil);
with fAboutBox do
begin
SetSubComponent(True); // Tell the IDE to store the modified properties
// Default of TAboutPlaySound values override TAbouBox.Create defaults
ComponentName := 'TAboutPlaySound';
Description.Add('This is to demonstrate'); //TStrings
Description.Add('the use of TAboutPlaySound'); //TStrings
Description.Add('Set its properties in your Constructor'); //TStrings
Width := 320; //Integer
Height := 280; //Integer
// Set any Font properties or subproperties here
// Font.Name := 'Arial';
Font.Color := clNavy;
Font.Size:=10;
// BackGroundColor shows if no BackGround image is set
BackGroundColor := clWindow;
Version := '1.0.0.0';
AuthorName := 'Gordon Bamber';
AuthorEmail := 'minesadorada@charcodelvalle.com';
Organisation := 'Public Domain';
//Types available: abNone, abGPL, abLGPL, abMIT, abModifiedGPL, abProprietry
LicenseType := abLGPL;
// BackGround image is optional
// It must be in a resouce file in the initialization section
//== How to set a background image to your About dialog --
// The BackGround property is a TBitmap
// Use a Temporary TPicture to load a JPG.
// NOTE a PNG file will create an error when your component is used in an application!
r := LazarusResources.Find(fAboutBox.BackgroundResourceName);
if r <> nil then
begin
TempImage := TPicture.Create;
// .lrs file is in the initialization section
TempImage.LoadFromLazarusResource(fAboutBox.BackgroundResourceName);
BackGround.Assign(TempImage.Bitmap);
TempImage.Free;
StretchBackground := fAboutBox.StretchBackground; //Boolean
end;
end;
end;
destructor TAboutPlaySound.Destroy;
begin
FreeAndNil(fAboutBox);
inherited Destroy;
end;
initialization
{$I license.lrs}
end.

Binary file not shown.

After

Width:  |  Height:  |  Size: 134 KiB

View File

@ -0,0 +1,98 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="PlaySound component demo"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<UseVersionInfo Value="True"/>
<RevisionNr Value="1"/>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="poweredby"/>
</Item1>
<Item2>
<PackageName Value="playwavepackage"/>
<MaxVersion Release="1"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="demo.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="demo"/>
</Unit0>
<Unit1>
<Filename Value="umainform.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="mainform"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="umainform"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="demo"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

View File

@ -0,0 +1,22 @@
program demo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, poweredby, umainform
{ you can add units after this };
{$R *.res}
begin
Application.Title:='PlaySound component demo';
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(Tmainform, mainform);
Application.Run;
end.

Binary file not shown.

Binary file not shown.

Binary file not shown.

View File

@ -0,0 +1,62 @@
object mainform: Tmainform
Left = 415
Height = 129
Top = 305
Width = 241
BorderIcons = [biSystemMenu]
Caption = 'mainform'
ClientHeight = 129
ClientWidth = 241
DefaultMonitor = dmPrimary
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '1.1'
object cmd_Async: TButton
Left = 16
Height = 25
Top = 16
Width = 75
Caption = 'Play Async'
OnClick = cmd_AsyncClick
TabOrder = 0
end
object BitBtn1: TBitBtn
Left = 152
Height = 30
Top = 88
Width = 75
DefaultCaption = True
Kind = bkClose
ModalResult = 11
TabOrder = 1
end
object cmd_Sync: TButton
Left = 152
Height = 25
Top = 16
Width = 75
Caption = 'Play Sync'
OnClick = cmd_SyncClick
TabOrder = 2
end
object playsound1: Tplaysound
About.Description.Strings = (
'Plays WAVE sounds in Windows or Linux'
)
About.Title = 'About PlaySound'
About.Height = 400
About.Width = 400
About.Font.Color = clNavy
About.Font.Height = -13
About.BackGroundColor = clCream
About.Version = '0.0.1'
About.Authorname = 'Gordon Bamber'
About.Organisation = 'Public Domain'
About.AuthorEmail = 'minesadorada@charcodelvalle.com'
About.ComponentName = 'PlaySound'
About.LicenseType = abLGPL
SoundFile = '/home/gordon/development/lazarus/'
left = 91
top = 53
end
end

View File

@ -0,0 +1,65 @@
unit umainform;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
StdCtrls, Buttons, uplaysound;
type
{ Tmainform }
Tmainform = class(TForm)
BitBtn1: TBitBtn;
cmd_Async: TButton;
cmd_Sync: TButton;
playsound1: Tplaysound;
procedure cmd_AsyncClick(Sender: TObject);
procedure cmd_SyncClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
mainform: Tmainform;
implementation
{$R *.lfm}
{ Tmainform }
procedure Tmainform.cmd_AsyncClick(Sender: TObject);
// No gap between sounds. App remains responsive
begin
playsound1.PlayStyle:=psASync;
playsound1.SoundFile:='doorbell.wav';
playsound1.Execute;
playsound1.SoundFile:='telephone.wav';
playsound1.Execute;
end;
procedure Tmainform.cmd_SyncClick(Sender: TObject);
begin
playsound1.PlayStyle:=psSync;
playsound1.SoundFile:='doorbell.wav';
playsound1.Execute;
playsound1.SoundFile:='telephone.wav';
playsound1.Execute;
end;
procedure Tmainform.FormCreate(Sender: TObject);
begin
Caption:=Application.Title;
Icon:=Application.Icon;
end;
end.

View File

@ -0,0 +1,72 @@
LazarusResources.Add('gpl.txt','TXT',[
' Copyright (C) <year> <name of author> <contact>'#13#10#13#10' This source'
+' is free software; you can redistribute it and/or modify it under'#13#10' '
+'the terms of the GNU General Public License as published by the Free'#13#10
+' Software Foundation; either version 2 of the License, or (at your option)'
+#13#10' any later version.'#13#10#13#10' This code is distributed in the h'
+'ope that it will be useful, but WITHOUT ANY'#13#10' WARRANTY; without even'
+' the implied warranty of MERCHANTABILITY or FITNESS'#13#10' FOR A PARTICUL'
+'AR PURPOSE. See the GNU General Public License for more'#13#10' details.'
+#13#10#13#10' A copy of the GNU General Public License is available on the '
+'World Wide Web'#13#10' at <http://www.gnu.org/copyleft/gpl.html>. You can '
+'also obtain it by writing'#13#10' to the Free Software Foundation, Inc., 5'
+'9 Temple Place - Suite 330, Boston,'#13#10' MA 02111-1307, USA.'
]);
LazarusResources.Add('lgpl.txt','TXT',[
' Copyright (C) <year> <name of author> <contact>'#13#10#13#10' This librar'
+'y is free software; you can redistribute it and/or modify it'#13#10' under'
+' the terms of the GNU Library General Public License as published by'#13#10
+' the Free Software Foundation; either version 2 of the License, or (at you'
+'r'#13#10' option) any later version.'#13#10#13#10' This program is distri'
+'buted in the hope that it will be useful, but WITHOUT'#13#10' ANY WARRANTY'
+'; without even the implied warranty of MERCHANTABILITY or'#13#10' FITNESS '
+'FOR A PARTICULAR PURPOSE. See the GNU Library General Public License'#13#10
+' for more details.'#13#10#13#10' You should have received a copy of the G'
+'NU Library General Public License'#13#10' along with this library; if not,'
+' write to the Free Software Foundation,'#13#10' Inc., 59 Temple Place - Su'
+'ite 330, Boston, MA 02111-1307, USA.'
]);
LazarusResources.Add('mit.txt','TXT',[
' Copyright (c) <year> <copyright holders>'#13#10#13#10' Permission is here'
+'by granted, free of charge, to any person obtaining a copy'#13#10' of this'
+' software and associated documentation files (the "Software"), to'#13#10' '
+'deal in the Software without restriction, including without limitation the'
+#13#10' rights to use, copy, modify, merge, publish, distribute, sublicense'
+', and/or'#13#10' sell copies of the Software, and to permit persons to who'
+'m the Software is'#13#10' furnished to do so, subject to the following con'
+'ditions:'#13#10#13#10' The above copyright notice and this permission noti'
+'ce shall be included in'#13#10' all copies or substantial portions of the '
+'Software.'#13#10#13#10' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY'
+' OF ANY KIND, EXPRESS OR'#13#10' IMPLIED, INCLUDING BUT NOT LIMITED TO THE'
+' WARRANTIES OF MERCHANTABILITY,'#13#10' FITNESS FOR A PARTICULAR PURPOSE A'
+'ND NONINFRINGEMENT. IN NO EVENT SHALL THE'#13#10' AUTHORS OR COPYRIGHT HOL'
+'DERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER'#13#10' LIABILITY, WHETHER '
+'IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING'#13#10' FROM, OUT OF '
+'OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS'#13#10' IN'
+' THE SOFTWARE.'
]);
LazarusResources.Add('modifiedgpl.txt','TXT',[
' Copyright (C) <year> <name of author> <contact>'#13#10#13#10' This librar'
+'y is free software; you can redistribute it and/or modify it'#13#10' under'
+' the terms of the GNU Library General Public License as published by'#13#10
+' the Free Software Foundation; either version 2 of the License, or (at you'
+'r'#13#10' option) any later version with the following modification:'#13#10
+#13#10' As a special exception, the copyright holders of this library give '
+'you'#13#10' permission to link this library with independent modules to pr'
+'oduce an'#13#10' executable, regardless of the license terms of these inde'
+'pendent modules,and'#13#10' to copy and distribute the resulting executabl'
+'e under terms of your choice,'#13#10' provided that you also meet, for eac'
+'h linked independent module, the terms'#13#10' and conditions of the licen'
+'se of that module. An independent module is a'#13#10' module which is not '
+'derived from or based on this library. If you modify'#13#10' this library,'
+' you may extend this exception to your version of the library,'#13#10' but'
+' you are not obligated to do so. If you do not wish to do so, delete this'
+#13#10' exception statement from your version.'#13#10#13#10' This program '
+'is distributed in the hope that it will be useful, but WITHOUT'#13#10' ANY'
+' WARRANTY; without even the implied warranty of MERCHANTABILITY or'#13#10' '
+' FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public Licen'
+'se'#13#10' for more details.'#13#10#13#10' You should have received a cop'
+'y of the GNU Library General Public License'#13#10' along with this librar'
+'y; if not, write to the Free Software Foundation,'#13#10' Inc., 59 Temple '
+'Place - Suite 330, Boston, MA 02111-1307, USA.'
]);

View File

@ -0,0 +1,35 @@
msgid ""
msgstr "Content-Type: text/plain; charset=UTF-8"
#: aboutplaysound.rs_about
msgid "About"
msgstr ""
#: aboutplaysound.rs_aboutboxerror
msgid "Subcomponent TAboutBox Error"
msgstr ""
#: aboutplaysound.rs_by
msgid "By"
msgstr ""
#: aboutplaysound.rs_componentname
msgid "Component name"
msgstr ""
#: aboutplaysound.rs_datafilemissing
msgid "Resource datafile license.lrs is missing"
msgstr ""
#: aboutplaysound.rs_for
msgid "For"
msgstr ""
#: aboutplaysound.rs_license
msgid "License"
msgstr ""
#: aboutplaysound.rs_licensetexterror
msgid "There is something wrong with the Licence text"
msgstr ""

View File

@ -0,0 +1,7 @@
msgid ""
msgstr "Content-Type: text/plain; charset=UTF-8"
#: uplaysound.c_unabletoplay
msgid "Unable to play "
msgstr ""

View File

@ -0,0 +1,42 @@
LazarusResources.Add('TPlaysound','PNG',[
#137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0
+#0#0#6'bKGD'#0#255#0#255#0#255#160#189#167#147#0#0#0#9'pHYs'#0#0#14#206#0#0
+#14#206#1#206'_'#197#247#0#0#0#7'tIME'#7#222#9#11#14'*'#1','#3#227';'#0#0#3
+'_IDATH'#199#141#214'K'#136#215'U'#20#7#240#207#252'G'#29'M'#19#173#204#154
+'$,5ln'#164'EI'#15#194'$k'#213#131#178'E'#166'a'#148'``-'#10#178#240#1#161
+#182#201'V'#138#149'-'#162'E'#134#4#9'eX'#248'"'#8#172' '#218#232#25'1M2)'
+#209#202#183'&'#234#204#180#248#157#255#204'_'#249#167#222#205'9'#191's'#238
+#189#231#253#189'?@Hz/'#241'b'#159#172'.'#191#212#234'='#255#18#241#244#249
+#178'>'#229'hbK'#242#195#137'v'#151#189'b<q}'#242#31#17'#'#235#154'Z'#195#174
+'W'#240'$1'#0#203'1'#225#2'O.'#226#185#137'XA'#244#199'R'#188'['#215#215'('
+#136'I8J9'#138'7'#177#131#242'5'#241'X'#165#255#191'U'#16#247'S'#214#224#251
+#234'l'#217#131#159#137#135#27'='#217'D'#12'"'#134#16'kS'#182#144'x'#234'2'
+#162'x'#136#152#147#252#15'D'#7#209'J,'#205#20#197#141#216'H'#249#23#31#226
+'=b('#6'R'#214#18#195#154'G'#17'-'#196#21#216#130')'#196'8'#204#192'|JWu'#190
+#170#193'M'#248#172#186#200'='#148'Mx'#31#171#136'k*za'#20#1#173#248#20'C1'
+#29#203'('#191#226#28'Q'#195'w'#196#180#26#198#227'0'#238#195#219#196#8#180
+'Q'#246'aqU'#252'x'#16#3#250#12#244#180'b&f'#227'sJ'#15'6'#167#147#219'0'#26
+#27#240'|'#13'cq'#2#29#213'f'#211'0'#175'j='#253#209#142#231#232'8'#155'a'
+#183'q['#23#238'H'#221'j'#226#22#252#136'qI'#167'g'#202#219'k'#24'I9'#135#17
+'8'#158#223'{'#240#2#222#168'r:f'#14'-W'#166#193'6jm'#156'y'#21'O`'#29'n'#197
+#239#152'Zu'#160#201#25#234#142'Z'#195','#12'B'#15#206#230#247'P'#202'!'#236
+'f'#224#185#212#29#199'1'#186#7'2'#177';#8'#156#6#14'V'#180#252#147#145#192
+#254'Z'#30#172#23'M'#195#247#201#28#186'?'#251#190'{W7-'#178'V]'#24'F'#233
+#198#144#212#215#233#233#198#8#186#146#182#244'ET'#206#164#151'0'#184#193'@'
+#141#158#22#156#174'z'#222#177#164'GS_'#167#131#251'5'#164#228'TFQ7x'#166#26
+'>'#183'W'#151#181#212'pm:p'#132#206'!'#216#155#181#235#172'jg{'#226#208#206
+#188'cT'#13#251#19'C'#254#202#158'>'#152']'#241#9#22#224'-:'#151#211's*'#243
+'|'#128'?Z0'#23#235#179#176#219'qs'#14']G'#213#178'`l'#13#191'd'#206#182#225
+#153'l'#213'%'#148#159#178#159'wU'#30'v'#142#236#203#208#145#146#145#30#194
+#163#148#221'x '#239#154'T'#221#17'Wag'#221'@;'#182#226#181#236#130#3#196#24
+',Ld'#253#178#146#245#174#29'X'#153#200#185#136#24'UEPN'#226'.'#202'^<'#142
+#21#181#170#13#205#166#156#192'W'#21#130'Z'#156#200#248'['#194#198'h'#202#217
+'>'#184'('#167'2'#247#31'Pv'#165#177#249#196#228#6'G:(['#235#216#178#190#10
+')'#6#16#223#164#236'Y'#226#227#228#251'5'#1#187'l'#134'XVAs'#180#18#251#136
+#171'S'#190#164'q'#243'u'#196#202#228#23#16#139#146#159'EL'#185#8'T'#207'%^N'
+'~'#30'1#'#249'w'#136#187'3'#226#222'''sqB7'#226'[bf'#147#151'KsY'#204'"6$?'
+#129'X'#211'ds'#220'@'#172#174#222'c'#136'u'#137#162#151'z'#232#239'$'#190
+#200#247'a8'#177'*'#135#238#188#169#173'o'#158#154#0#246'z'#5#3'FQ.'#241'k'
+#17#237#248';''})'#214'R6W'#14#148#166#30'=R'#165#235'b'#233'i'#154#166#153
+#233#224'y'#235'?'#247')('#135#205' '#216'A'#0#0#0#0'IEND'#174'B`'#130
]);

Binary file not shown.

After

Width:  |  Height:  |  Size: 978 B

View File

@ -0,0 +1,22 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit playsoundackage;
interface
uses
uplaysound, aboutplaysound, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('uplaysound', @uplaysound.Register);
RegisterUnit('aboutplaysound', @aboutplaysound.Register);
end;
initialization
RegisterPackage('playsoundackage', @Register);
end.

View File

@ -0,0 +1,56 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="4">
<Name Value="playwavepackage"/>
<Author Value="minesadorada"/>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="Simple component to play wave files under Windows or Linux"/>
<License Value="LGPLv2"/>
<Version Release="1"/>
<Files Count="2">
<Item1>
<Filename Value="uplaysound.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="uplaysound"/>
</Item1>
<Item2>
<Filename Value="aboutplaysound.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="aboutplaysound"/>
</Item2>
</Files>
<i18n>
<EnableI18N Value="True"/>
<OutDir Value="locale"/>
<EnableI18NForLFM Value="True"/>
</i18n>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

View File

@ -0,0 +1,22 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit playwavepackage;
interface
uses
uplaysound, aboutplaysound, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('uplaysound', @uplaysound.Register);
RegisterUnit('aboutplaysound', @aboutplaysound.Register);
end;
initialization
RegisterPackage('playwavepackage', @Register);
end.

View File

@ -0,0 +1,25 @@
PlayWavePackage
===============
A simple visual component to play WAVe files in Windows or Linux
Licence
=======
LGPLv2
Author
======
minesadorada
Compatibility
=============
Tested in:
Windows Vista 32-bit
Linux Mint 64-bit
Should work with:
All versions of Windows
Most versions of Linux
Maybe Macintosh OSX
:Gordon Bamber September 2014

View File

@ -0,0 +1,147 @@
unit uplaysound;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs
,FileUtil{$IFDEF WINDOWS},mmsystem{$ELSE},asyncprocess,process{$ENDIF},aboutplaysound;
type
TPlayStyle = (psAsync,psSync);
Tplaysound = class(TAboutPlaySound)
private
{ Private declarations }
{$IFDEF LINUX}
SoundPlayerAsyncProcess:Tasyncprocess;
SoundPlayerSyncProcess:Tprocess;
{$ENDIF}
fPathToSoundFile:String;
fPlayStyle:TPlayStyle;
protected
{ Protected declarations }
procedure PlaySound(Const szSoundFilename:String); virtual;
public
{ Public declarations }
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; reintroduce;
procedure Execute;
published
{ Published declarations }
Property SoundFile:String read fPathToSoundFile write fPathToSoundFile;
Property PlayStyle:TPlayStyle read fPlayStyle write fPlayStyle default psASync;
end;
procedure Register;
implementation
{$IFDEF LINUX}
CONST // Defined in mmsystem
SND_SYNC=0;
SND_ASYNC=1;
SND_NODEFAULT=2;
{$ENDIF}
resourcestring
C_UnableToPlay = 'Unable to play ';
Constructor Tplaysound.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fPlayStyle:=psASync;
fPathToSoundFile:=ProgramDirectory;
// About Dialog properties
AboutBoxComponentName:='PlaySound';
AboutBoxWidth:=400;
AboutBoxHeight:=400;
AboutBoxBackgroundColor:=clCream;
//AboutBoxFontName (string)
//AboutBoxFontSize (integer)
AboutBoxVersion:='0.0.1';
AboutBoxAuthorname:='Gordon Bamber';
AboutBoxOrganisation:='Public Domain';
AboutBoxAuthorEmail:='minesadorada@charcodelvalle.com';
AboutBoxLicenseType:='LGPL';
AboutBoxDescription:='Plays WAVE sounds in Windows or Linux';
end;
Destructor Tplaysound.Destroy;
begin
{$IFDEF LINUX}
FreeAndNil(SoundPlayerSyncProcess);
FreeAndNil(SoundPlayerAsyncProcess);
{$ENDIF}
inherited;
end;
procedure Tplaysound.Execute;
begin
If Not FileExistsUTF8(fPathToSoundFile) then Exit;
PlaySound(fPathToSoundFile);
end;
procedure Tplaysound.PlaySound(Const szSoundFilename:String);
Var
flags:Word;
linuxplaycommand:String;
begin
linuxplaycommand:='';
{$IFDEF WINDOWS}
If fPlayStyle = psASync then flags:=SND_ASYNC OR SND_NODEFAULT
else flags:=SND_SYNC OR SND_NODEFAULT;
TRY
sndPlaySound(PChar(szSoundFilename),flags);
except
ShowMessage(C_UnableToPlay + szSoundFilename);
end;
{$ELSE}
// How to play in Linux? Use generic Linux commands
// Use asyncprocess to play sound as SND_ASYNC
// Try play
If (FindDefaultExecutablePath('play') <> '') then linuxplaycommand:='play';
// Try aplay
If (linuxplaycommand='') then
If (FindDefaultExecutablePath('aplay') <> '') Then linuxplaycommand:='aplay';
// Try paplay
If (linuxplaycommand='') then
If (FindDefaultExecutablePath('paplay') <> '') Then linuxplaycommand:='paplay';
// proceed if we managed to find a valid command
If (linuxplaycommand <> '') then
BEGIN
If fPlayStyle = psASync then
begin
If SoundPlayerAsyncProcess=Nil then SoundPlayerAsyncProcess:=Tasyncprocess.Create(Nil);
SoundPlayerAsyncProcess.CurrentDirectory:=ExtractFileDir(szSoundFilename);
SoundPlayerAsyncProcess.Executable:=FindDefaultExecutablePath(linuxplaycommand);
SoundPlayerAsyncProcess.Parameters.Clear;
SoundPlayerAsyncProcess.Parameters.Add(szSoundFilename);
TRY
SoundPlayerAsyncProcess.Execute;
except
ShowMessage('Playstyle=paASync: ' + C_UnableToPlay + szSoundFilename);
end;
end
else
begin
If SoundPlayerSyncProcess=Nil then SoundPlayerSyncProcess:=Tprocess.Create(Nil);
SoundPlayerSyncProcess.CurrentDirectory:=ExtractFileDir(szSoundFilename);
SoundPlayerSyncProcess.Executable:=FindDefaultExecutablePath(linuxplaycommand);
SoundPlayersyncProcess.Parameters.Clear;
SoundPlayerSyncProcess.Parameters.Add(szSoundFilename);
TRY
SoundPlayerSyncProcess.Execute;
SoundPlayersyncProcess.WaitOnExit;
except
ShowMessage('Playstyle=paSyncSync: ' + C_UnableToPlay + szSoundFilename);
end;
end;
END;
{$ENDIF}
end;
procedure Register;
begin
RegisterComponents('LazControls',[Tplaysound]);
{$I playsound_icon.lrs}
end;
end.