WebSVN – spacemission – Blame – /VCL_DELPHIX_D6/DXSounds.pas

Rev	Author	Line No.	Line
1	daniel-mar	1	unit DXSounds;
		2
		3	interface
		4
		5	{$INCLUDE DelphiXcfg.inc}
		6
		7	uses
		8	Windows, Messages, SysUtils, Classes, Controls, Forms, ExtCtrls, MMSystem,
		9	DirectX, DXClass, Wave;
		10
		11	type
		12
		13	{ EDirectSoundError }
		14
		15	EDirectSoundError = class(EDirectXError);
		16	EDirectSoundBufferError = class(EDirectSoundError);
		17
		18	{ TDirectSound }
		19
		20	TDirectSoundBuffer = class;
		21
		22	TDirectSound = class(TDirectX)
		23	private
		24	FBufferList: TList;
		25	FGlobalFocus: Boolean;
		26	FIDSound: IDirectSound;
		27	FInRestoreBuffer: Boolean;
		28	FStickyFocus: Boolean;
		29	function GetBuffer(Index: Integer): TDirectSoundBuffer;
		30	function GetBufferCount: Integer;
		31	function GetIDSound: IDirectSound;
		32	function GetISound: IDirectSound;
		33	protected
		34	procedure CheckBuffer(Buffer: TDirectSoundBuffer);
		35	procedure DoRestoreBuffer; virtual;
		36	public
		37	constructor Create(GUID: PGUID);
		38	destructor Destroy; override;
		39	class function Drivers: TDirectXDrivers;
		40	property BufferCount: Integer read GetBufferCount;
		41	property Buffers[Index: Integer]: TDirectSoundBuffer read GetBuffer;
		42	property IDSound: IDirectSound read GetIDSound;
		43	property ISound: IDirectSound read GetISound;
		44	end;
		45
		46	{ TDirectSoundBuffer }
		47
		48	TDirectSoundBuffer = class(TDirectX)
		49	private
		50	FDSound: TDirectSound;
		51	FIDSBuffer: IDirectSoundBuffer;
		52	FCaps: TDSBCaps;
		53	FFormat: PWaveFormatEx;
		54	FFormatSize: Integer;
		55	FLockAudioPtr1, FLockAudioPtr2: array[0..0] of Pointer;
		56	FLockAudioSize1, FLockAudioSize2: array[0..0] of DWORD;
		57	FLockCount: Integer;
		58	function GetBitCount: Longint;
		59	function GetFormat: PWaveFormatEx;
		60	function GetFrequency: Integer;
		61	function GetIDSBuffer: IDirectSoundBuffer;
		62	function GetIBuffer: IDirectSoundBuffer;
		63	function GetPlaying: Boolean;
		64	function GetPan: Integer;
		65	function GetPosition: Longint;
		66	function GetSize: Integer;
		67	function GetStatus: Integer;
		68	function GetVolume: Integer;
		69	procedure SetFrequency(Value: Integer);
		70	procedure SetIDSBuffer(Value: IDirectSoundBuffer);
		71	procedure SetPan(Value: Integer);
		72	procedure SetPosition(Value: Longint);
		73	procedure SetVolume(Value: Integer);
		74	protected
		75	procedure Check; override;
		76	public
		77	constructor Create(ADirectSound: TDirectSound);
		78	destructor Destroy; override;
		79	procedure Assign(Source: TPersistent); override;
		80	function CreateBuffer(const BufferDesc: TDSBufferDesc): Boolean;
		81	procedure LoadFromFile(const FileName: string);
		82	procedure LoadFromMemory(const Format: TWaveFormatEx;
		83	Data: Pointer; Size: Integer);
		84	procedure LoadFromStream(Stream: TStream);
		85	procedure LoadFromWave(Wave: TWave);
		86	function Lock(LockPosition, LockSize: Longint;
		87	var AudioPtr1: Pointer; var AudioSize1: Longint;
		88	var AudioPtr2: Pointer; var AudioSize2: Longint): Boolean;
		89	function Play(Loop: Boolean{$IFNDEF VER100}=False{$ENDIF}): Boolean;
		90	function Restore: Boolean;
		91	function SetFormat(const Format: TWaveFormatEx): Boolean;
		92	procedure SetSize(const Format: TWaveFormatEx; Size: Integer);
		93	procedure Stop;
		94	procedure UnLock;
		95	property BitCount: Longint read GetBitCount;
		96	property DSound: TDirectSound read FDSound;
		97	property Format: PWaveFormatEx read GetFormat;
		98	property FormatSize: Integer read FFormatSize;
		99	property Frequency: Integer read GetFrequency write SetFrequency;
		100	property IBuffer: IDirectSoundBuffer read GetIBuffer;
		101	property IDSBuffer: IDirectSoundBuffer read GetIDSBuffer write SetIDSBuffer;
		102	property Playing: Boolean read GetPlaying;
		103	property Pan: Integer read GetPan write SetPan;
		104	property Position: Longint read GetPosition write SetPosition;
		105	property Size: Integer read GetSize;
		106	property Volume: Integer read GetVolume write SetVolume;
		107	end;
		108
		109	{ EAudioStreamError }
		110
		111	EAudioStreamError = class(Exception);
		112
		113	{ TAudioStream }
		114
		115	TAudioStream = class
		116	private
		117	FAutoUpdate: Boolean;
		118	FBuffer: TDirectSoundBuffer;
		119	FBufferLength: Integer;
		120	FBufferPos: DWORD;
		121	FPlayBufferPos: DWORD;
		122	FBufferSize: DWORD;
		123	FDSound: TDirectSound;
		124	FLooped: Boolean;
		125	FPlayedSize: Integer;
		126	FPlaying: Boolean;
		127	FPosition: Integer;
		128	FWaveStream: TCustomWaveStream;
		129	FWritePosition: Integer;
		130	FNotifyEvent: THandle;
		131	FNotifyThread: TThread;
		132	function GetFormat: PWaveFormatEX;
		133	function GetFormatSize: Integer;
		134	function GetFrequency: Integer;
		135	function GetPan: Integer;
		136	function GetPlayedSize: Integer;
		137	function GetSize: Integer;
		138	function GetVolume: Integer;
		139	function GetWriteSize: Integer;
		140	procedure SetAutoUpdate(Value: Boolean);
		141	procedure SetBufferLength(Value: Integer);
		142	procedure SetFrequency(Value: Integer);
		143	procedure SetLooped(Value: Boolean);
		144	procedure SetPan(Value: Integer);
		145	procedure SetPlayedSize(Value: Integer);
		146	procedure SetPosition(Value: Integer);
		147	procedure SetVolume(Value: Integer);
		148	procedure SetWaveStream(Value: TCustomWaveStream);
		149	procedure Update2(InThread: Boolean);
		150	procedure UpdatePlayedSize;
		151	function WriteWave(WriteSize: Integer): Integer;
		152	public
		153	constructor Create(ADirectSound: TDirectSound);
		154	destructor Destroy; override;
		155	procedure Play;
		156	procedure RecreateBuf;
		157	procedure Stop;
		158	procedure Update;
		159	property AutoUpdate: Boolean read FAutoUpdate write SetAutoUpdate;
		160	property BufferLength: Integer read FBufferLength write SetBufferLength;
		161	property Format: PWaveFormatEx read GetFormat;
		162	property FormatSize: Integer read GetFormatSize;
		163	property Frequency: Integer read GetFrequency write SetFrequency;
		164	property Pan: Integer read GetPan write SetPan;
		165	property PlayedSize: Integer read GetPlayedSize write SetPlayedSize;
		166	property Playing: Boolean read FPlaying;
		167	property Position: Integer read FPosition write SetPosition;
		168	property Looped: Boolean read FLooped write SetLooped;
		169	property Size: Integer read GetSize;
		170	property Volume: Integer read GetVolume write SetVolume;
		171	property WaveStream: TCustomWaveStream read FWaveStream write SetWaveStream;
		172	end;
		173
		174	{ TAudioFileStream }
		175
		176	TAudioFileStream = class(TAudioStream)
		177	private
		178	FFileName: string;
		179	FWaveFileStream: TWaveFileStream;
		180	procedure SetFileName(const Value: string);
		181	public
		182	destructor Destroy; override;
		183	property FileName: string read FFileName write SetFileName;
		184	end;
		185
		186	{ TSoundCaptureFormat }
		187
		188	TSoundCaptureFormat = class(TCollectionItem)
		189	private
		190	FBitsPerSample: Integer;
		191	FChannels: Integer;
		192	FSamplesPerSec: Integer;
		193	public
		194	property BitsPerSample: Integer read FBitsPerSample;
		195	property Channels: Integer read FChannels;
		196	property SamplesPerSec: Integer read FSamplesPerSec;
		197	end;
		198
		199	{ TSoundCaptureFormats }
		200
		201	TSoundCaptureFormats = class(TCollection)
		202	private
		203	function GetItem(Index: Integer): TSoundCaptureFormat;
		204	public
		205	constructor Create;
		206	function IndexOf(ASamplesPerSec, ABitsPerSample, AChannels: Integer): Integer;
		207	property Items[Index: Integer]: TSoundCaptureFormat read GetItem; default;
		208	end;
		209
		210	{ TSoundCaptureStream }
		211
		212	ESoundCaptureStreamError = class(EWaveStreamError);
		213
		214	TSoundCaptureStream = class(TCustomWaveStream2)
		215	private
		216	FBuffer: IDirectSoundCaptureBuffer;
		217	FBufferLength: Integer;
		218	FBufferPos: DWORD;
		219	FBufferSize: DWORD;
		220	FCapture: IDirectSoundCapture;
		221	FCaptureFormat: Integer;
		222	FCapturing: Boolean;
		223	FNotifyEvent: THandle;
		224	FNotifyThread: TThread;
		225	FOnFilledBuffer: TNotifyEvent;
		226	FSupportedFormats: TSoundCaptureFormats;
		227	function GetReadSize: Integer;
		228	procedure SetBufferLength(Value: Integer);
		229	procedure SetOnFilledBuffer(Value: TNotifyEvent);
		230	protected
		231	procedure DoFilledBuffer; virtual;
		232	function GetFilledSize: Integer; override;
		233	function ReadWave(var Buffer; Count: Integer): Integer; override;
		234	public
		235	constructor Create(GUID: PGUID);
		236	destructor Destroy; override;
		237	class function Drivers: TDirectXDrivers;
		238	procedure Start;
		239	procedure Stop;
		240	property BufferLength: Integer read FBufferLength write SetBufferLength;
		241	property CaptureFormat: Integer read FCaptureFormat write FCaptureFormat;
		242	property Capturing: Boolean read FCapturing;
		243	property OnFilledBuffer: TNotifyEvent read FOnFilledBuffer write SetOnFilledBuffer;
		244	property SupportedFormats: TSoundCaptureFormats read FSupportedFormats;
		245	end;
		246
		247	{ TSoundEngine }
		248
		249	TSoundEngine = class
		250	private
		251	FDSound: TDirectSound;
		252	FEffectList: TList;
		253	FEnabled: Boolean;
		254	FTimer: TTimer;
		255	function GetEffect(Index: Integer): TDirectSoundBuffer;
		256	function GetEffectCount: Integer;
		257	procedure SetEnabled(Value: Boolean);
		258	procedure TimerEvent(Sender: TObject);
		259	public
		260	constructor Create(ADSound: TDirectSound);
		261	destructor Destroy; override;
		262	procedure Clear;
		263	procedure EffectFile(const Filename: string; Loop, Wait: Boolean);
		264	procedure EffectStream(Stream: TStream; Loop, Wait: Boolean);
		265	procedure EffectWave(Wave: TWave; Loop, Wait: Boolean);
		266	property EffectCount: Integer read GetEffectCount;
		267	property Effects[Index: Integer]: TDirectSoundBuffer read GetEffect;
		268	property Enabled: Boolean read FEnabled write SetEnabled;
		269	end;
		270
		271	{ EDXSoundError }
		272
		273	EDXSoundError = class(Exception);
		274
		275	{ TCustomDXSound }
		276
		277	TCustomDXSound = class;
		278
		279	TDXSoundOption = (soGlobalFocus, soStickyFocus, soExclusive);
		280	TDXSoundOptions = set of TDXSoundOption;
		281
		282	TDXSoundNotifyType = (dsntDestroying, dsntInitializing, dsntInitialize, dsntFinalize, dsntRestore);
		283	TDXSoundNotifyEvent = procedure(Sender: TCustomDXSound; NotifyType: TDXSoundNotifyType) of object;
		284
		285	TCustomDXSound = class(TComponent)
		286	private
		287	FAutoInitialize: Boolean;
		288	FCalledDoInitialize: Boolean;
		289	FDriver: PGUID;
		290	FDriverGUID: TGUID;
		291	FDSound: TDirectSound;
		292	FForm: TCustomForm;
		293	FInitialized: Boolean;
		294	FInternalInitialized: Boolean;
		295	FNotifyEventList: TList;
		296	FNowOptions: TDXSoundOptions;
		297	FOnFinalize: TNotifyEvent;
		298	FOnInitialize: TNotifyEvent;
		299	FOnInitializing: TNotifyEvent;
		300	FOnRestore: TNotifyEvent;
		301	FOptions: TDXSoundOptions;
		302	FPrimary: TDirectSoundBuffer;
		303	FSubClass: TControlSubClass;
		304	procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
		305	procedure NotifyEventList(NotifyType: TDXSoundNotifyType);
		306	procedure SetDriver(Value: PGUID);
		307	procedure SetForm(Value: TCustomForm);
		308	procedure SetOptions(Value: TDXSoundOptions);
		309	protected
		310	procedure DoFinalize; virtual;
		311	procedure DoInitialize; virtual;
		312	procedure DoInitializing; virtual;
		313	procedure DoRestore; virtual;
		314	procedure Loaded; override;
		315	public
		316	constructor Create(AOwner: TComponent); override;
		317	destructor Destroy; override;
		318	class function Drivers: TDirectXDrivers;
		319	procedure Finalize;
		320	procedure Initialize;
		321	procedure Restore;
		322	procedure RegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);
		323	procedure UnRegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);
		324
		325	property AutoInitialize: Boolean read FAutoInitialize write FAutoInitialize;
		326	property Driver: PGUID read FDriver write SetDriver;
		327	property DSound: TDirectSound read FDSound;
		328	property Initialized: Boolean read FInitialized;
		329	property NowOptions: TDXSoundOptions read FNowOptions;
		330	property Primary: TDirectSoundBuffer read FPrimary;
		331	property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
		332	property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
		333	property OnInitializing: TNotifyEvent read FOnInitializing write FOnInitializing;
		334	property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
		335	property Options: TDXSoundOptions read FOptions write SetOptions;
		336	end;
		337
		338	{ TDXSound }
		339
		340	TDXSound = class(TCustomDXSound)
		341	published
		342	property AutoInitialize;
		343	property Options;
		344	property OnFinalize;
		345	property OnInitialize;
		346	property OnInitializing;
		347	property OnRestore;
		348	end;
		349
		350	{ EWaveCollectionError }
		351
		352	EWaveCollectionError = class(Exception);
		353
		354	{ TWaveCollectionItem }
		355
		356	TWaveCollection = class;
		357
		358	TWaveCollectionItem = class(THashCollectionItem)
		359	private
		360	FBuffer: TDirectSoundBuffer;
		361	FBufferList: TList;
		362	FFrequency: Integer;
		363	FInitialized: Boolean;
		364	FLooped: Boolean;
		365	FMaxPlayingCount: Integer;
		366	FPan: Integer;
		367	FVolume: Integer;
		368	FWave: TWave;
		369	function CreateBuffer: TDirectSoundBuffer;
		370	procedure Finalize;
		371	procedure Initialize;
		372	function GetBuffer: TDirectSoundBuffer;
		373	function GetWaveCollection: TWaveCollection;
		374	procedure SetFrequency(Value: Integer);
		375	procedure SetLooped(Value: Boolean);
		376	procedure SetMaxPlayingCount(Value: Integer);
		377	procedure SetPan(Value: Integer);
		378	procedure SetVolume(Value: Integer);
		379	procedure SetWave(Value: TWave);
		380	public
		381	constructor Create(Collection: TCollection); override;
		382	destructor Destroy; override;
		383	procedure Assign(Source: TPersistent); override;
		384	procedure Play(Wait: Boolean);
		385	procedure Restore;
		386	procedure Stop;
		387	property Frequency: Integer read FFrequency write SetFrequency;
		388	property Initialized: Boolean read FInitialized;
		389	property Pan: Integer read FPan write SetPan;
		390	property Volume: Integer read FVolume write SetVolume;
		391	property WaveCollection: TWaveCollection read GetWaveCollection;
		392	published
		393	property Looped: Boolean read FLooped write SetLooped;
		394	property MaxPlayingCount: Integer read FMaxPlayingCount write SetMaxPlayingCount;
		395	property Wave: TWave read FWave write SetWave;
		396	end;
		397
		398	{ TWaveCollection }
		399
		400	TWaveCollection = class(THashCollection)
		401	private
		402	FDXSound: TCustomDXSound;
		403	FOwner: TPersistent;
		404	function GetItem(Index: Integer): TWaveCollectionItem;
		405	function Initialized: Boolean;
		406	protected
		407	function GetOwner: TPersistent; override;
		408	public
		409	constructor Create(AOwner: TPersistent);
		410	function Find(const Name: string): TWaveCollectionItem;
		411	procedure Finalize;
		412	procedure Initialize(DXSound: TCustomDXSound);
		413	procedure Restore;
		414	procedure LoadFromFile(const FileName: string);
		415	procedure LoadFromStream(Stream: TStream);
		416	procedure SaveToFile(const FileName: string);
		417	procedure SaveToStream(Stream: TStream);
		418	property DXSound: TCustomDXSound read FDXSound;
		419	property Items[Index: Integer]: TWaveCollectionItem read GetItem; default;
		420	end;
		421
		422	{ TCustomDXWaveList }
		423
		424	TCustomDXWaveList = class(TComponent)
		425	private
		426	FDXSound: TCustomDXSound;
		427	FItems: TWaveCollection;
		428	procedure DXSoundNotifyEvent(Sender: TCustomDXSound; NotifyType: TDXSoundNotifyType);
		429	procedure SetDXSound(Value: TCustomDXSound);
		430	procedure SetItems(Value: TWaveCollection);
		431	protected
		432	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
		433	public
		434	constructor Create(AOwner: TComponent); override;
		435	destructor Destroy; override;
		436	property DXSound: TCustomDXSound read FDXSound write SetDXSound;
		437	property Items: TWaveCollection read FItems write SetItems;
		438	end;
		439
		440	{ TDXWaveList }
		441
		442	TDXWaveList = class(TCustomDXWaveList)
		443	published
		444	property DXSound;
		445	property Items;
		446	end;
		447
		448	implementation
		449
		450	uses DXConsts;
		451
		452	function DXDirectSoundCreate(lpGUID: PGUID; out lpDS: IDirectSound;
		453	pUnkOuter: IUnknown): HRESULT;
		454	type
		455	TDirectSoundCreate = function(lpGUID: PGUID; out lplpDD: IDirectSound;
		456	pUnkOuter: IUnknown): HRESULT; stdcall;
		457	begin
		458	Result := TDirectSoundCreate(DXLoadLibrary('DSound.dll', 'DirectSoundCreate'))
		459	(lpGUID, lpDS, pUnkOuter);
		460	end;
		461
		462	function DXDirectSoundEnumerate(lpCallback: TDSEnumCallbackA;
		463	lpContext: Pointer): HRESULT;
		464	type
		465	TDirectSoundEnumerate = function(lpCallback: TDSEnumCallbackA;
		466	lpContext: Pointer): HRESULT; stdcall;
		467	begin
		468	Result := TDirectSoundEnumerate(DXLoadLibrary('DSound.dll', 'DirectSoundEnumerateA'))
		469	(lpCallback, lpContext);
		470	end;
		471
		472	function DXDirectSoundCaptureCreate(lpGUID: PGUID; out lplpDSC: IDirectSoundCapture;
		473	pUnkOuter: IUnknown): HRESULT;
		474	type
		475	TDirectSoundCaptureCreate = function(lpGUID: PGUID; out lplpDD: IDirectSoundCapture;
		476	pUnkOuter: IUnknown): HRESULT; stdcall;
		477	begin
		478	try
		479	Result := TDirectSoundCaptureCreate(DXLoadLibrary('DSound.dll', 'DirectSoundCaptureCreate'))
		480	(lpGUID, lplpDSC, pUnkOuter);
		481	except
		482	raise EDirectXError.Create(SSinceDirectX5);
		483	end;
		484	end;
		485
		486	function DXDirectSoundCaptureEnumerate(lpCallback: TDSEnumCallbackA;
		487	lpContext: Pointer): HRESULT;
		488	type
		489	TDirectSoundCaptureEnumerate = function(lpCallback: TDSEnumCallbackA;
		490	lpContext: Pointer): HRESULT; stdcall;
		491	begin
		492	try
		493	Result := TDirectSoundCaptureEnumerate(DXLoadLibrary('DSound.dll', 'DirectSoundCaptureEnumerateA'))
		494	(lpCallback, lpContext);
		495	except
		496	raise EDirectXError.Create(SSinceDirectX5);
		497	end;
		498	end;
		499
		500	var
		501	DirectSoundDrivers: TDirectXDrivers;
		502	DirectSoundCaptureDrivers: TDirectXDrivers;
		503
		504	function EnumDirectSoundDrivers_DSENUMCALLBACK(lpGuid: PGUID; lpstrDescription: LPCSTR;
		505	lpstrModule: LPCSTR; lpContext: Pointer): BOOL; stdcall;
		506	begin
		507	Result := True;
		508	with TDirectXDriver.Create(TDirectXDrivers(lpContext)) do
		509	begin
		510	Guid := lpGuid;
		511	Description := lpstrDescription;
		512	DriverName := lpstrModule;
		513	end;
		514	end;
		515
		516	function EnumDirectSoundDrivers: TDirectXDrivers;
		517	begin
		518	if DirectSoundDrivers=nil then
		519	begin
		520	DirectSoundDrivers := TDirectXDrivers.Create;
		521	try
		522	DXDirectSoundEnumerate(@EnumDirectSoundDrivers_DSENUMCALLBACK, DirectSoundDrivers);
		523	except
		524	DirectSoundDrivers.Free;
		525	raise;
		526	end;
		527	end;
		528
		529	Result := DirectSoundDrivers;
		530	end;
		531
		532	function EnumDirectSoundCaptureDrivers: TDirectXDrivers;
		533	begin
		534	if DirectSoundCaptureDrivers=nil then
		535	begin
		536	DirectSoundCaptureDrivers := TDirectXDrivers.Create;
		537	try
		538	DXDirectSoundCaptureEnumerate(@EnumDirectSoundDrivers_DSENUMCALLBACK, DirectSoundCaptureDrivers);
		539	except
		540	DirectSoundCaptureDrivers.Free;
		541	raise;
		542	end;
		543	end;
		544
		545	Result := DirectSoundCaptureDrivers;
		546	end;
		547
		548	{ TDirectSound }
		549
		550	constructor TDirectSound.Create(GUID: PGUID);
		551	begin
		552	inherited Create;
		553	FBufferList := TList.Create;
		554
		555	if DXDirectSoundCreate(GUID, FIDSound, nil)<>DS_OK then
		556	raise EDirectSoundError.CreateFmt(SCannotInitialized, [SDirectSound]);
		557	end;
		558
		559	destructor TDirectSound.Destroy;
		560	begin
		561	while BufferCount>0 do
		562	Buffers[BufferCount-1].Free;
		563	FBufferList.Free;
		564
		565	FIDSound := nil;
		566	inherited Destroy;
		567	end;
		568
		569	class function TDirectSound.Drivers: TDirectXDrivers;
		570	begin
		571	Result := EnumDirectSoundDrivers;
		572	end;
		573
		574	procedure TDirectSound.CheckBuffer(Buffer: TDirectSoundBuffer);
		575	begin
		576	case Buffer.DXResult of
		577	DSERR_BUFFERLOST:
		578	begin
		579	if not FInRestoreBuffer then
		580	begin
		581	FInRestoreBuffer := True;
		582	try
		583	DoRestoreBuffer;
		584	finally
		585	FInRestoreBuffer := False;
		586	end;
		587	end;
		588	end;
		589	end;
		590	end;
		591
		592	procedure TDirectSound.DoRestoreBuffer;
		593	begin
		594	end;
		595
		596	function TDirectSound.GetBuffer(Index: Integer): TDirectSoundBuffer;
		597	begin
		598	Result := FBufferList[Index];
		599	end;
		600
		601	function TDirectSound.GetBufferCount: Integer;
		602	begin
		603	Result := FBufferList.Count;
		604	end;
		605
		606	function TDirectSound.GetIDSound: IDirectSound;
		607	begin
		608	if Self<>nil then
		609	Result := FIDSound
		610	else
		611	Result := nil;
		612	end;
		613
		614	function TDirectSound.GetISound: IDirectSound;
		615	begin
		616	Result := IDSound;
		617	if Result=nil then
		618	raise EDirectSoundError.CreateFmt(SNotMade, ['IDirectSound']);
		619	end;
		620
		621	{ TDirectSoundBuffer }
		622
		623	constructor TDirectSoundBuffer.Create(ADirectSound: TDirectSound);
		624	begin
		625	inherited Create;
		626	FDSound := ADirectSound;
		627	FDSound.FBufferList.Add(Self);
		628	end;
		629
		630	destructor TDirectSoundBuffer.Destroy;
		631	begin
		632	IDSBuffer := nil;
		633	FDSound.FBufferList.Remove(Self);
		634	inherited Destroy;
		635	end;
		636
		637	procedure TDirectSoundBuffer.Assign(Source: TPersistent);
		638	var
		639	TempBuffer: IDirectSoundBuffer;
		640	begin
		641	if Source=nil then
		642	IDSBuffer := nil
		643	else if Source is TWave then
		644	LoadFromWave(TWave(Source))
		645	else if Source is TDirectSoundBuffer then
		646	begin
		647	if TDirectSoundBuffer(Source).IDSBuffer=nil then
		648	IDSBuffer := nil
		649	else begin
		650	FDSound.DXResult := FDSound.ISound.DuplicateSoundBuffer(TDirectSoundBuffer(Source).IDSBuffer,
		651	TempBuffer);
		652	if FDSound.DXResult=0 then
		653	begin
		654	IDSBuffer := TempBuffer;
		655	end;
		656	end;
		657	end else
		658	inherited Assign(Source);
		659	end;
		660
		661	procedure TDirectSoundBuffer.Check;
		662	begin
		663	FDSound.CheckBuffer(Self);
		664	end;
		665
		666	function TDirectSoundBuffer.CreateBuffer(const BufferDesc: TDSBufferDesc): Boolean;
		667	var
		668	TempBuffer: IDirectSoundBuffer;
		669	begin
		670	IDSBuffer := nil;
		671
		672	FDSound.DXResult := FDSound.ISound.CreateSoundBuffer(BufferDesc, TempBuffer, nil);
		673	FDXResult := FDSound.DXResult;
		674	Result := DXResult=DS_OK;
		675	if Result then
		676	IDSBuffer := TempBuffer;
		677	end;
		678
		679	function TDirectSoundBuffer.GetBitCount: Longint;
		680	begin
		681	Result := Format.wBitsPerSample;
		682	end;
		683
		684	function TDirectSoundBuffer.GetFormat: PWaveFormatEx;
		685	begin
		686	GetIBuffer;
		687	Result := FFormat;
		688	end;
		689
		690	function TDirectSoundBuffer.GetFrequency: Integer;
		691	begin
		692	DXResult := IBuffer.GetFrequency(DWORD(Result));
		693	end;
		694
		695	function TDirectSoundBuffer.GetIDSBuffer: IDirectSoundBuffer;
		696	begin
		697	if Self<>nil then
		698	Result := FIDSBuffer
		699	else
		700	Result := nil;
		701	end;
		702
		703	function TDirectSoundBuffer.GetIBuffer: IDirectSoundBuffer;
		704	begin
		705	Result := IDSBuffer;
		706	if Result=nil then
		707	raise EDirectSoundBufferError.CreateFmt(SNotMade, ['IDirectSoundBuffer']);
		708	end;
		709
		710	function TDirectSoundBuffer.GetPlaying: Boolean;
		711	begin
		712	Result := (GetStatus and (DSBSTATUS_PLAYING or DSBSTATUS_LOOPING))<>0;
		713	end;
		714
		715	function TDirectSoundBuffer.GetPan: Integer;
		716	begin
		717	DXResult := IBuffer.GetPan(Longint(Result));
		718	end;
		719
		720	function TDirectSoundBuffer.GetPosition: Longint;
		721	var
		722	dwCurrentWriteCursor: Longint;
		723	begin
		724	IBuffer.GetCurrentPosition(DWORD(Result), DWORD(dwCurrentWriteCursor));
		725	end;
		726
		727	function TDirectSoundBuffer.GetSize: Integer;
		728	begin
		729	Result := FCaps.dwBufferBytes;
		730	end;
		731
		732	function TDirectSoundBuffer.GetStatus: Integer;
		733	begin
		734	DXResult := IBuffer.GetStatus(DWORD(Result));
		735	end;
		736
		737	function TDirectSoundBuffer.GetVolume: Integer;
		738	begin
		739	DXResult := IBuffer.GetVolume(Longint(Result));
		740	end;
		741
		742	procedure TDirectSoundBuffer.LoadFromFile(const FileName: string);
		743	var
		744	Stream : TFileStream;
		745	begin
		746	Stream := TFileStream.Create(FileName, fmOpenRead);
		747	try
		748	LoadFromStream(Stream);
		749	finally
		750	Stream.Free;
		751	end;
		752	end;
		753
		754	procedure TDirectSoundBuffer.LoadFromMemory(const Format: TWaveFormatEx;
		755	Data: Pointer; Size: Integer);
		756	var
		757	Data1, Data2: Pointer;
		758	Data1Size, Data2Size: Longint;
		759	begin
		760	SetSize(Format, Size);
		761
		762	if Data<>nil then
		763	begin
		764	if Lock(0, Size, Data1, Data1Size, Data2, Data2Size) then
		765	begin
		766	try
		767	Move(Data^, Data1^, Data1Size);
		768	if Data2<>nil then
		769	Move(Pointer(Longint(Data)+Data1Size)^, Data2^, Data2Size);
		770	finally
		771	UnLock;
		772	end;
		773	end else
		774	begin
		775	FIDSBuffer := nil;
		776	raise EDirectSoundBufferError.CreateFmt(SCannotLock, [SDirectSoundBuffer]);
		777	end;
		778	end;
		779	end;
		780
		781	procedure TDirectSoundBuffer.LoadFromStream(Stream: TStream);
		782	var
		783	Wave: TWave;
		784	begin
		785	Wave := TWave.Create;
		786	try
		787	Wave.LoadFromStream(Stream);
		788	LoadFromWave(Wave);
		789	finally
		790	Wave.Free;
		791	end;
		792	end;
		793
		794	procedure TDirectSoundBuffer.LoadFromWave(Wave: TWave);
		795	begin
		796	LoadFromMemory(Wave.Format^, Wave.Data, Wave.Size);
		797	end;
		798
		799	function TDirectSoundBuffer.Lock(LockPosition, LockSize: Longint;
		800	var AudioPtr1: Pointer; var AudioSize1: Longint;
		801	var AudioPtr2: Pointer; var AudioSize2: Longint): Boolean;
		802	begin
		803	Result := False;
		804	if IDSBuffer=nil then Exit;
		805
		806	if FLockCount>High(FLockAudioPtr1) then Exit;
		807
		808	DXResult := IBuffer.Lock(LockPosition, LockSize,
		809	FLockAudioPtr1[FLockCount], FLockAudioSize1[FLockCount],
		810	FLockAudioPtr2[FLockCount], FLockAudioSize2[FLockCount], 0);
		811	Result := DXResult=DS_OK;
		812
		813	if Result then
		814	begin
		815	AudioPtr1 := FLockAudioPtr1[FLockCount];
		816	AudioPtr2 := FLockAudioPtr2[FLockCount];
		817	AudioSize1 := FLockAudioSize1[FLockCount];
		818	AudioSize2 := FLockAudioSize2[FLockCount];
		819	Inc(FLockCount);
		820	end;
		821	end;
		822
		823	function TDirectSoundBuffer.Play(Loop: Boolean): Boolean;
		824	begin
		825	if Loop then
		826	DXResult := IBuffer.Play(0, 0, DSBPLAY_LOOPING)
		827	else
		828	DXResult := IBuffer.Play(0, 0, 0);
		829	Result := DXResult=DS_OK;
		830	end;
		831
		832	function TDirectSoundBuffer.Restore: Boolean;
		833	begin
		834	DXResult := IBuffer.Restore;
		835	Result := DXResult=DS_OK;
		836	end;
		837
		838	function TDirectSoundBuffer.SetFormat(const Format: TWaveFormatEx): Boolean;
		839	begin
		840	DXResult := IBuffer.SetFormat(Format);
		841	Result := DXResult=DS_OK;
		842
		843	if Result then
		844	begin
		845	FreeMem(FFormat);
		846	FFormat := nil;
		847	FFormatSize := 0;
		848	if IBuffer.GetFormat(PWaveFormatEx(nil)^, 0, DWORD(FFormatSize))=DS_OK then
		849	begin
		850	GetMem(FFormat, FFormatSize);
		851	IBuffer.GetFormat(FFormat^, FFormatSize, PDWORD(nil)^);
		852	end;
		853	end;
		854	end;
		855
		856	procedure TDirectSoundBuffer.SetFrequency(Value: Integer);
		857	begin
		858	DXResult := IBuffer.SetFrequency(Value);
		859	end;
		860
		861	procedure TDirectSoundBuffer.SetIDSBuffer(Value: IDirectSoundBuffer);
		862	begin
		863	if FIDSBuffer=Value then Exit;
		864
		865	FIDSBuffer := Value;
		866	FillChar(FCaps, SizeOf(FCaps), 0);
		867	FreeMem(FFormat);
		868	FFormat := nil;
		869	FFormatSize := 0;
		870	FLockCount := 0;
		871
		872	if FIDSBuffer<>nil then
		873	begin
		874	FCaps.dwSize := SizeOf(FCaps);
		875	IBuffer.GetCaps(FCaps);
		876
		877	if IBuffer.GetFormat(PWaveFormatEx(nil)^, 0, DWORD(FFormatSize))=DS_OK then
		878	begin
		879	GetMem(FFormat, FFormatSize);
		880	IBuffer.GetFormat(FFormat^, FFormatSize, PDWORD(nil)^);
		881	end;
		882	end;
		883	end;
		884
		885	procedure TDirectSoundBuffer.SetPan(Value: Integer);
		886	begin
		887	DXResult := IBuffer.SetPan(Value);
		888	end;
		889
		890	procedure TDirectSoundBuffer.SetPosition(Value: Longint);
		891	begin
		892	DXResult := IBuffer.SetCurrentPosition(Value);
		893	end;
		894
		895	procedure TDirectSoundBuffer.SetSize(const Format: TWaveFormatEx; Size: Integer);
		896	var
		897	BufferDesc: TDSBufferDesc;
		898	begin
		899	{ IDirectSoundBuffer made. }
		900	FillChar(BufferDesc, SizeOf(BufferDesc), 0);
		901
		902	with BufferDesc do
		903	begin
		904	dwSize := SizeOf(TDSBufferDesc);
		905	dwFlags := DSBCAPS_CTRLDEFAULT;
		906	if DSound.FStickyFocus then
		907	dwFlags := dwFlags or DSBCAPS_STICKYFOCUS
		908	else if DSound.FGlobalFocus then
		909	dwFlags := dwFlags or DSBCAPS_GLOBALFOCUS;
		910	dwBufferBytes := Size;
		911	lpwfxFormat := @Format;
		912	end;
		913
		914	if not CreateBuffer(BufferDesc) then
		915	raise EDirectSoundBufferError.CreateFmt(SCannotMade, [SDirectSoundBuffer]);
		916	end;
		917
		918	procedure TDirectSoundBuffer.SetVolume(Value: Integer);
		919	begin
		920	DXResult := IBuffer.SetVolume(Value);
		921	end;
		922
		923	procedure TDirectSoundBuffer.Stop;
		924	begin
		925	DXResult := IBuffer.Stop;
		926	end;
		927
		928	procedure TDirectSoundBuffer.Unlock;
		929	begin
		930	if IDSBuffer=nil then Exit;
		931	if FLockCount=0 then Exit;
		932
		933	Dec(FLockCount);
		934	DXResult := IBuffer.UnLock(FLockAudioPtr1[FLockCount], FLockAudioSize1[FLockCount],
		935	FLockAudioPtr2[FLockCount], FLockAudioSize2[FLockCount]);
		936	end;
		937
		938	{ TAudioStream }
		939
		940	type
		941	TAudioStreamNotify = class(TThread)
		942	private
		943	FAudio: TAudioStream;
		944	FSleepTime: Integer;
		945	FStopOnTerminate: Boolean;
		946	constructor Create(Audio: TAudioStream);
		947	destructor Destroy; override;
		948	procedure Execute; override;
		949	procedure Update;
		950	procedure ThreadTerminate(Sender: TObject);
		951	end;
		952
		953	constructor TAudioStreamNotify.Create(Audio: TAudioStream);
		954	begin
		955	FAudio := Audio;
		956
		957	OnTerminate := ThreadTerminate;
		958
		959	FAudio.FNotifyEvent := CreateEvent(nil, False, False, nil);
		960	FAudio.FNotifyThread := Self;
		961
		962	FSleepTime := Min(FAudio.FBufferLength div 4, 1000 div 20);
		963	FStopOnTerminate := True;
		964
		965	FreeOnTerminate := True;
		966	inherited Create(False);
		967	end;
		968
		969	destructor TAudioStreamNotify.Destroy;
		970	begin
		971	FreeOnTerminate := False;
		972
		973	SetEvent(FAudio.FNotifyEvent);
		974	inherited Destroy;
		975	CloseHandle(FAudio.FNotifyEvent);
		976
		977	FAudio.FNotifyThread := nil;
		978	end;
		979
		980	procedure TAudioStreamNotify.ThreadTerminate(Sender: TObject);
		981	begin
		982	FAudio.FNotifyThread := nil;
		983	if FStopOnTerminate then FAudio.Stop;
		984	end;
		985
		986	procedure TAudioStreamNotify.Execute;
		987	begin
		988	while WaitForSingleObject(FAudio.FNotifyEvent, FSleepTime)=WAIT_TIMEOUT do
		989	Synchronize(Update);
		990	end;
		991
		992	procedure TAudioStreamNotify.Update;
		993	begin
		994	if not FAudio.Playing then
		995	begin
		996	SetEvent(FAudio.FNotifyEvent);
		997	EXit;
		998	end;
		999
		1000	try
		1001	FAudio.Update2(True);
		1002	except
		1003	on E: Exception do
		1004	begin
		1005	Application.HandleException(E);
		1006	SetEvent(FAudio.FNotifyEvent);
		1007	end;
		1008	end;
		1009	end;
		1010
		1011	constructor TAudioStream.Create(ADirectSound: TDirectSound);
		1012	begin
		1013	inherited Create;
		1014	FDSound := ADirectSound;
		1015	FAutoUpdate := True;
		1016	FBuffer := TDirectSoundBuffer.Create(FDSound);
		1017	FBufferLength := 1000;
		1018	end;
		1019
		1020	destructor TAudioStream.Destroy;
		1021	begin
		1022	Stop;
		1023	WaveStream := nil;
		1024	FBuffer.Free;
		1025	inherited Destroy;
		1026	end;
		1027
		1028	function TAudioStream.GetFormat: PWaveFormatEX;
		1029	begin
		1030	if WaveStream=nil then
		1031	raise EAudioStreamError.Create(SWaveStreamNotSet);
		1032	Result := WaveStream.Format;
		1033	end;
		1034
		1035	function TAudioStream.GetFormatSize: Integer;
		1036	begin
		1037	if WaveStream=nil then
		1038	raise EAudioStreamError.Create(SWaveStreamNotSet);
		1039	Result := WaveStream.FormatSize;
		1040	end;
		1041
		1042	function TAudioStream.GetFrequency: Integer;
		1043	begin
		1044	Result := FBuffer.Frequency;
		1045	end;
		1046
		1047	function TAudioStream.GetPan: Integer;
		1048	begin
		1049	Result := FBuffer.Pan;
		1050	end;
		1051
		1052	function TAudioStream.GetPlayedSize: Integer;
		1053	begin
		1054	if Playing then UpdatePlayedSize;
		1055	Result := FPlayedSize;
		1056	end;
		1057
		1058	function TAudioStream.GetSize: Integer;
		1059	begin
		1060	if WaveStream<>nil then
		1061	Result := WaveStream.Size
		1062	else
		1063	Result := 0;
		1064	end;
		1065
		1066	function TAudioStream.GetVolume: Integer;
		1067	begin
		1068	Result := FBuffer.Volume;
		1069	end;
		1070
		1071	procedure TAudioStream.UpdatePlayedSize;
		1072	var
		1073	PlayPosition, PlayedSize: DWORD;
		1074	begin
		1075	PlayPosition := FBuffer.Position;
		1076
		1077	if FPlayBufferPos <= PlayPosition then
		1078	begin
		1079	PlayedSize := PlayPosition - FPlayBufferPos
		1080	end else
		1081	begin
		1082	PlayedSize := PlayPosition + (FBufferSize - FPlayBufferPos);
		1083	end;
		1084
		1085	Inc(FPlayedSize, PlayedSize);
		1086
		1087	FPlayBufferPos := PlayPosition;
		1088	end;
		1089
		1090	function TAudioStream.GetWriteSize: Integer;
		1091	var
		1092	PlayPosition: DWORD;
		1093	i: Integer;
		1094	begin
		1095	PlayPosition := FBuffer.Position;
		1096
		1097	if FBufferPos <= PlayPosition then
		1098	begin
		1099	Result := PlayPosition - FBufferPos
		1100	end else
		1101	begin
		1102	Result := PlayPosition + (FBufferSize - FBufferPos);
		1103	end;
		1104
		1105	i := WaveStream.FilledSize;
		1106	if i>=0 then Result := Min(Result, i);
		1107	end;
		1108
		1109	procedure TAudioStream.Play;
		1110	begin
		1111	if not FPlaying then
		1112	begin
		1113	if WaveStream=nil then
		1114	raise EAudioStreamError.Create(SWaveStreamNotSet);
		1115
		1116	if Size=0 then Exit;
		1117
		1118	FPlaying := True;
		1119	try
		1120	SetPosition(FPosition);
		1121	if FAutoUpdate then
		1122	FNotifyThread := TAudioStreamNotify.Create(Self);
		1123	except
		1124	Stop;
		1125	raise;
		1126	end;
		1127	end;
		1128	end;
		1129
		1130	procedure TAudioStream.RecreateBuf;
		1131	var
		1132	APlaying: Boolean;
		1133	APosition: Integer;
		1134	AFrequency: Integer;
		1135	APan: Integer;
		1136	AVolume: Integer;
		1137	begin
		1138	APlaying := Playing;
		1139
		1140	APosition := Position;
		1141	AFrequency := Frequency;
		1142	APan := Pan;
		1143	AVolume := Volume;
		1144
		1145	SetWaveStream(WaveStream);
		1146
		1147	Position := APosition;
		1148	Frequency := AFrequency;
		1149	Pan := APan;
		1150	Volume := AVolume;
		1151
		1152	if APlaying then Play;
		1153	end;
		1154
		1155	procedure TAudioStream.SetAutoUpdate(Value: Boolean);
		1156	begin
		1157	if FAutoUpdate<>Value then
		1158	begin
		1159	FAutoUpdate := Value;
		1160	if FPlaying then
		1161	begin
		1162	if FNotifyThread<>nil then
		1163	begin
		1164	(FNotifyThread as TAudioStreamNotify).FStopOnTerminate := False;
		1165	FNotifyThread.Free;
		1166	end;
		1167
		1168	if FAutoUpdate then
		1169	FNotifyThread := TAudioStreamNotify.Create(Self);
		1170	end;
		1171	end;
		1172	end;
		1173
		1174	procedure TAudioStream.SetBufferLength(Value: Integer);
		1175	begin
		1176	if Value<10 then Value := 10;
		1177	if FBufferLength<>Value then
		1178	begin
		1179	FBufferLength := Value;
		1180	if WaveStream<>nil then RecreateBuf;
		1181	end;
		1182	end;
		1183
		1184	procedure TAudioStream.SetFrequency(Value: Integer);
		1185	begin
		1186	FBuffer.Frequency := Value;
		1187	end;
		1188
		1189	procedure TAudioStream.SetLooped(Value: Boolean);
		1190	begin
		1191	if FLooped<>Value then
		1192	begin
		1193	FLooped := Value;
		1194	Position := Position;
		1195	end;
		1196	end;
		1197
		1198	procedure TAudioStream.SetPan(Value: Integer);
		1199	begin
		1200	FBuffer.Pan := Value;
		1201	end;
		1202
		1203	procedure TAudioStream.SetPlayedSize(Value: Integer);
		1204	begin
		1205	if Playing then UpdatePlayedSize;
		1206	FPlayedSize := Value;
		1207	end;
		1208
		1209	procedure TAudioStream.SetPosition(Value: Integer);
		1210	begin
		1211	if WaveStream=nil then
		1212	raise EAudioStreamError.Create(SWaveStreamNotSet);
		1213
		1214	Value := Max(Min(Value, Size-1), 0);
		1215	Value := Value div Format^.nBlockAlign * Format^.nBlockAlign;
		1216
		1217	FPosition := Value;
		1218
		1219	if Playing then
		1220	begin
		1221	try
		1222	FBuffer.Stop;
		1223
		1224	FBufferPos := 0;
		1225	FPlayBufferPos := 0;
		1226	FWritePosition := Value;
		1227
		1228	WriteWave(FBufferSize);
		1229
		1230	FBuffer.Position := 0;
		1231	FBuffer.Play(True);
		1232	except
		1233	Stop;
		1234	raise;
		1235	end;
		1236	end;
		1237	end;
		1238
		1239	procedure TAudioStream.SetVolume(Value: Integer);
		1240	begin
		1241	FBuffer.Volume := Value;
		1242	end;
		1243
		1244	procedure TAudioStream.SetWaveStream(Value: TCustomWaveStream);
		1245	var
		1246	BufferDesc: TDSBufferDesc;
		1247	begin
		1248	Stop;
		1249
		1250	FWaveStream := nil;
		1251	FBufferPos := 0;
		1252	FPosition := 0;
		1253	FWritePosition := 0;
		1254
		1255	if (Value<>nil) and (FBufferLength>0) then
		1256	begin
		1257	FBufferSize := FBufferLength * Integer(Value.Format^.nAvgBytesPerSec) div 1000;
		1258
		1259	FillChar(BufferDesc, SizeOf(BufferDesc), 0);
		1260	with BufferDesc do
		1261	begin
		1262	dwSize := SizeOf(TDSBufferDesc);
		1263	dwFlags := DSBCAPS_CTRLDEFAULT or DSBCAPS_GETCURRENTPOSITION2;
		1264	if FDSound.FStickyFocus then
		1265	dwFlags := dwFlags or DSBCAPS_STICKYFOCUS
		1266	else if FDSound.FGlobalFocus then
		1267	dwFlags := dwFlags or DSBCAPS_GLOBALFOCUS;
		1268	dwBufferBytes := FBufferSize;
		1269	lpwfxFormat := Value.Format;
		1270	end;
		1271
		1272	if not FBuffer.CreateBuffer(BufferDesc) then
		1273	raise EDirectSoundBufferError.CreateFmt(SCannotMade, [SDirectSoundBuffer]);
		1274	end else
		1275	begin
		1276	FBuffer.IDSBuffer := nil;
		1277	FBufferSize := 0;
		1278	end;
		1279
		1280	FWaveStream := Value;
		1281	end;
		1282
		1283	procedure TAudioStream.Stop;
		1284	begin
		1285	if FPlaying then
		1286	begin
		1287	FPlaying := False;
		1288	FBuffer.Stop;
		1289	FNotifyThread.Free;
		1290	end;
		1291	end;
		1292
		1293	procedure TAudioStream.Update;
		1294	begin
		1295	Update2(False);
		1296	end;
		1297
		1298	procedure TAudioStream.Update2(InThread: Boolean);
		1299	var
		1300	WriteSize: Integer;
		1301	begin
		1302	if not FPlaying then Exit;
		1303
		1304	try
		1305	UpdatePlayedSize;
		1306
		1307	if Size<0 then
		1308	begin
		1309	WriteSize := GetWriteSize;
		1310	if WriteSize>0 then
		1311	begin
		1312	WriteSize := WriteWave(WriteSize);
		1313	FPosition := FPosition + WriteSize;
		1314	end;
		1315	end else
		1316	begin
		1317	if FLooped then
		1318	begin
		1319	WriteSize := GetWriteSize;
		1320	if WriteSize>0 then
		1321	begin
		1322	WriteWave(WriteSize);
		1323	FPosition := (FPosition + WriteSize) mod Size;
		1324	end;
		1325	end else
		1326	begin
		1327	if FPosition<Size then
		1328	begin
		1329	WriteSize := GetWriteSize;
		1330	if WriteSize>0 then
		1331	begin
		1332	WriteWave(WriteSize);
		1333	FPosition := FPosition + WriteSize;
		1334	if FPosition>Size then FPosition := Size;
		1335	end;
		1336	end else
		1337	begin
		1338	if InThread then
		1339	SetEvent(FNotifyEvent)
		1340	else
		1341	Stop;
		1342	end;
		1343	end;
		1344	end;
		1345	except
		1346	if InThread then
		1347	SetEvent(FNotifyEvent)
		1348	else
		1349	Stop;
		1350	raise;
		1351	end;
		1352	end;
		1353
		1354	function TAudioStream.WriteWave(WriteSize: Integer): Integer;
		1355
		1356	procedure WriteData(Size: Integer);
		1357	var
		1358	Data1, Data2: Pointer;
		1359	Data1Size, Data2Size: Longint;
		1360	begin
		1361	if FBuffer.Lock(FBufferPos, Size, Data1, Data1Size, Data2, Data2Size) then
		1362	begin
		1363	try
		1364	FWaveStream.Position := FWritePosition;
		1365	FWaveStream.ReadBuffer(Data1^, Data1Size);
		1366	FWritePosition := FWritePosition + Data1Size;
		1367
		1368	if Data2<>nil then
		1369	begin
		1370	FWaveStream.ReadBuffer(Data2^, Data2Size);
		1371	FWritePosition := FWritePosition + Data2Size;
		1372	end;
		1373
		1374	FBufferPos := (FBufferPos + DWORD(Data1Size) + DWORD(Data2Size)) mod FBufferSize;
		1375	finally
		1376	FBuffer.UnLock;
		1377	end;
		1378	end;
		1379	end;
		1380
		1381	procedure WriteData2(Size: Integer);
		1382	var
		1383	Data1, Data2: Pointer;
		1384	Data1Size, Data2Size, s1, s2: Longint;
		1385	begin
		1386	if FBuffer.Lock(FBufferPos, Size, Data1, Data1Size, Data2, Data2Size) then
		1387	begin
		1388	try
		1389	FWaveStream.Position := FWritePosition;
		1390	s1 := FWaveStream.Read(Data1^, Data1Size);
		1391	FWritePosition := FWritePosition + s1;
		1392	FBufferPos := (FBufferPos + DWORD(s1)) mod FBufferSize;
		1393	Inc(Result, s1);
		1394
		1395	if (Data2<>nil) and (s1=Data1Size) then
		1396	begin
		1397	s2 := FWaveStream.Read(Data2^, Data2Size);
		1398	FWritePosition := FWritePosition + s2;
		1399	FBufferPos := (FBufferPos + DWORD(s2)) mod FBufferSize;
		1400	Inc(Result, s2);
		1401	end;
		1402	finally
		1403	FBuffer.UnLock;
		1404	end;
		1405	end;
		1406	end;
		1407
		1408	procedure WriteSilence(Size: Integer);
		1409	var
		1410	C: Byte;
		1411	Data1, Data2: Pointer;
		1412	Data1Size, Data2Size: Longint;
		1413	begin
		1414	if Format^.wBitsPerSample=8 then C := $80 else C := 0;
		1415
		1416	if FBuffer.Lock(FBufferPos, Size, Data1, Data1Size, Data2, Data2Size) then
		1417	begin
		1418	try
		1419	FillChar(Data1^, Data1Size, C);
		1420
		1421	if Data2<>nil then
		1422	FillChar(Data2^, Data2Size, C);
		1423	finally
		1424	FBuffer.UnLock;
		1425	end;
		1426	FBufferPos := (FBufferPos + DWORD(Data1Size) + DWORD(Data2Size)) mod FBufferSize;
		1427	FWritePosition := FWritePosition + Data1Size + Data2Size;
		1428	end;
		1429	end;
		1430
		1431	var
		1432	DataSize: Integer;
		1433	begin
		1434	if Size>=0 then
		1435	begin
		1436	Result := WriteSize;
		1437	if FLooped then
		1438	begin
		1439	while WriteSize>0 do
		1440	begin
		1441	DataSize := Min(Size-FWritePosition, WriteSize);
		1442
		1443	WriteData(DataSize);
		1444	FWritePosition := FWritePosition mod Size;
		1445
		1446	Dec(WriteSize, DataSize);
		1447	end;
		1448	end else
		1449	begin
		1450	DataSize := Size-FWritePosition;
		1451
		1452	if DataSize<=0 then
		1453	begin
		1454	WriteSilence(WriteSize);
		1455	end else
		1456	if DataSize>=WriteSize then
		1457	begin
		1458	WriteData(WriteSize);
		1459	end else
		1460	begin
		1461	WriteData(DataSize);
		1462	WriteSilence(WriteSize-DataSize);
		1463	end;
		1464	end;
		1465	end else
		1466	begin
		1467	Result := 0;
		1468	WriteData2(WriteSize);
		1469	end;
		1470	end;
		1471
		1472	{ TAudioFileStream }
		1473
		1474	destructor TAudioFileStream.Destroy;
		1475	begin
		1476	inherited Destroy;
		1477	FWaveFileStream.Free;
		1478	end;
		1479
		1480	procedure TAudioFileStream.SetFileName(const Value: string);
		1481	begin
		1482	if FFileName=Value then Exit;
		1483
		1484	FFileName := Value;
		1485
		1486	if FWaveFileStream<>nil then
		1487	begin
		1488	WaveStream := nil;
		1489	FWaveFileStream.Free;
		1490	FWaveFileStream := nil;
		1491	end;
		1492
		1493	if Value<>'' then
		1494	begin
		1495	try
		1496	FWaveFileStream := TWaveFileStream.Create(Value, fmOpenRead or fmShareDenyWrite);
		1497	FWaveFileStream.Open(False);
		1498	WaveStream := FWaveFileStream;
		1499	except
		1500	WaveStream := nil;
		1501	FFileName := '';
		1502	raise;
		1503	end;
		1504	end;
		1505	end;
		1506
		1507	{ TSoundCaptureFormats }
		1508
		1509	constructor TSoundCaptureFormats.Create;
		1510	begin
		1511	inherited Create(TSoundCaptureFormat);
		1512	end;
		1513
		1514	function TSoundCaptureFormats.GetItem(Index: Integer): TSoundCaptureFormat;
		1515	begin
		1516	Result := TSoundCaptureFormat(inherited Items[Index]);
		1517	end;
		1518
		1519	function TSoundCaptureFormats.IndexOf(ASamplesPerSec, ABitsPerSample, AChannels: Integer): Integer;
		1520	var
		1521	i: Integer;
		1522	begin
		1523	Result := -1;
		1524	for i:=0 to Count-1 do
		1525	with Items[i] do
		1526	if (FSamplesPerSec=ASamplesPerSec) and (FBitsPerSample=ABitsPerSample) and (FChannels=AChannels) then
		1527	begin
		1528	Result := i;
		1529	Break;
		1530	end;
		1531	end;
		1532
		1533	{ TSoundCaptureStream }
		1534
		1535	type
		1536	TSoundCaptureStreamNotify = class(TThread)
		1537	private
		1538	FCapture: TSoundCaptureStream;
		1539	FSleepTime: Integer;
		1540	constructor Create(Capture: TSoundCaptureStream);
		1541	destructor Destroy; override;
		1542	procedure Execute; override;
		1543	procedure Update;
		1544	end;
		1545
		1546	constructor TSoundCaptureStreamNotify.Create(Capture: TSoundCaptureStream);
		1547	begin
		1548	FCapture := Capture;
		1549
		1550	FCapture.FNotifyEvent := CreateEvent(nil, False, False, nil);
		1551	FSleepTime := Min(FCapture.FBufferLength div 4, 1000 div 20);
		1552
		1553	FreeOnTerminate := True;
		1554	inherited Create(True);
		1555	end;
		1556
		1557	destructor TSoundCaptureStreamNotify.Destroy;
		1558	begin
		1559	FreeOnTerminate := False;
		1560	SetEvent(FCapture.FNotifyEvent);
		1561
		1562	inherited Destroy;
		1563
		1564	CloseHandle(FCapture.FNotifyEvent);
		1565	FCapture.FNotifyThread := nil;
		1566
		1567	if Assigned(FCapture.FOnFilledBuffer) then FCapture.Stop;
		1568	end;
		1569
		1570	procedure TSoundCaptureStreamNotify.Execute;
		1571	begin
		1572	while WaitForSingleObject(FCapture.FNotifyEvent, FSleepTime)=WAIT_TIMEOUT do
		1573	begin
		1574	Synchronize(Update);
		1575	end;
		1576	end;
		1577
		1578	procedure TSoundCaptureStreamNotify.Update;
		1579	begin
		1580	if FCapture.FilledSize>0 then
		1581	begin
		1582	try
		1583	FCapture.DoFilledBuffer;
		1584	except
		1585	on E: Exception do
		1586	begin
		1587	Application.HandleException(E);
		1588	SetEvent(FCapture.FNotifyEvent);
		1589	end;
		1590	end;
		1591	end;
		1592	end;
		1593
		1594	constructor TSoundCaptureStream.Create(GUID: PGUID);
		1595	const
		1596	SamplesPerSecList: array[0..6] of Integer = (8000, 11025, 22050, 33075, 44100, 48000, 96000);
		1597	BitsPerSampleList: array[0..3] of Integer = (8, 16, 24, 32);
		1598	ChannelsList: array[0..1] of Integer = (1, 2);
		1599	var
		1600	ASamplesPerSec, ABitsPerSample, AChannels: Integer;
		1601	dscbd: TDSCBufferDesc;
		1602	TempBuffer: IDirectSoundCaptureBuffer;
		1603	Format: TWaveFormatEx;
		1604	begin
		1605	inherited Create;
		1606	FBufferLength := 1000;
		1607	FSupportedFormats := TSoundCaptureFormats.Create;
		1608
		1609	if DXDirectSoundCaptureCreate(GUID, FCapture, nil)<>DS_OK then
		1610	raise ESoundCaptureStreamError.CreateFmt(SCannotInitialized, [SDirectSoundCapture]);
		1611
		1612	{ The supported format list is acquired. }
		1613	for ASamplesPerSec:=Low(SamplesPerSecList) to High(SamplesPerSecList) do
		1614	for ABitsPerSample:=Low(BitsPerSampleList) to High(BitsPerSampleList) do
		1615	for AChannels:=Low(ChannelsList) to High(ChannelsList) do
		1616	begin
		1617	{ Test }
		1618	MakePCMWaveFormatEx(Format, SamplesPerSecList[ASamplesPerSec], BitsPerSampleList[ABitsPerSample], ChannelsList[AChannels]);
		1619
		1620	FillChar(dscbd, SizeOf(dscbd), 0);
		1621	dscbd.dwSize := SizeOf(dscbd);
		1622	dscbd.dwBufferBytes := Format.nAvgBytesPerSec;
		1623	dscbd.lpwfxFormat := @Format;
		1624
		1625	{ If the buffer can be made, the format of present can be used. }
		1626	if FCapture.CreateCaptureBuffer(dscbd, TempBuffer, nil)=DS_OK then
		1627	begin
		1628	TempBuffer := nil;
		1629	with TSoundCaptureFormat.Create(FSupportedFormats) do
		1630	begin
		1631	FSamplesPerSec := Format.nSamplesPerSec;
		1632	FBitsPerSample := Format.wBitsPerSample;
		1633	FChannels := Format.nChannels;
		1634	end;
		1635	end;
		1636	end;
		1637	end;
		1638
		1639	destructor TSoundCaptureStream.Destroy;
		1640	begin
		1641	Stop;
		1642	FSupportedFormats.Free;
		1643	inherited Destroy;
		1644	end;
		1645
		1646	procedure TSoundCaptureStream.DoFilledBuffer;
		1647	begin
		1648	if Assigned(FOnFilledBuffer) then FOnFilledBuffer(Self);
		1649	end;
		1650
		1651	class function TSoundCaptureStream.Drivers: TDirectXDrivers;
		1652	begin
		1653	Result := EnumDirectSoundCaptureDrivers;
		1654	end;
		1655
		1656	function TSoundCaptureStream.GetFilledSize: Integer;
		1657	begin
		1658	Result := GetReadSize;
		1659	end;
		1660
		1661	function TSoundCaptureStream.GetReadSize: Integer;
		1662	var
		1663	CapturePosition, ReadPosition: DWORD;
		1664	begin
		1665	if FBuffer.GetCurrentPosition(CapturePosition, ReadPosition)=DS_OK then
		1666	begin
		1667	if FBufferPos<=ReadPosition then
		1668	Result := ReadPosition - FBufferPos
		1669	else
		1670	Result := FBufferSize - FBufferPos + ReadPosition;
		1671	end else
		1672	Result := 0;
		1673	end;
		1674
		1675	function TSoundCaptureStream.ReadWave(var Buffer; Count: Integer): Integer;
		1676	var
		1677	Size: Integer;
		1678	Data1, Data2: Pointer;
		1679	Data1Size, Data2Size: DWORD;
		1680	C: Byte;
		1681	begin
		1682	if not FCapturing then
		1683	Start;
		1684
		1685	Result := 0;
		1686	while Result<Count do
		1687	begin
		1688	Size := Min(Count-Result, GetReadSize);
		1689	if Size>0 then
		1690	begin
		1691	if FBuffer.Lock(FBufferPos, Size, Data1, Data1Size, Data2, Data2Size, 0)=DS_OK then
		1692	begin
		1693	Move(Data1^, Pointer(Integer(@Buffer)+Result)^, Data1Size);
		1694	Result := Result + Integer(Data1Size);
		1695
		1696	if Data2<>nil then
		1697	begin
		1698	Move(Data2^, Pointer(Integer(@Buffer)+Result)^, Data2Size);
		1699	Result := Result + Integer(Data1Size);
		1700	end;
		1701
		1702	FBuffer.UnLock(Data1, Data1Size, Data2, Data2Size);
		1703	FBufferPos := (FBufferPos + Data1Size + Data2Size) mod FBufferSize;
		1704	end else
		1705	Break;
		1706	end;
		1707	if Result<Count then Sleep(50);
		1708	end;
		1709
		1710	case Format^.wBitsPerSample of
		1711	8: C := $80;
		1712	16: C := $00;
		1713	else
		1714	C := $00;
		1715	end;
		1716
		1717	FillChar(Pointer(Integer(@Buffer)+Result)^, Count-Result, C);
		1718	Result := Count;
		1719	end;
		1720
		1721	procedure TSoundCaptureStream.SetBufferLength(Value: Integer);
		1722	begin
		1723	FBufferLength := Max(Value, 0);
		1724	end;
		1725
		1726	procedure TSoundCaptureStream.SetOnFilledBuffer(Value: TNotifyEvent);
		1727	begin
		1728	if CompareMem(@TMethod(FOnFilledBuffer), @TMethod(Value), SizeOf(TMethod)) then Exit;
		1729
		1730	if FCapturing then
		1731	begin
		1732	if Assigned(FOnFilledBuffer) then
		1733	FNotifyThread.Free;
		1734
		1735	FOnFilledBuffer := Value;
		1736
		1737	if Assigned(FOnFilledBuffer) then
		1738	begin
		1739	FNotifyThread := TSoundCaptureStreamNotify.Create(Self);
		1740	FNotifyThread.Resume;
		1741	end;
		1742	end else
		1743	FOnFilledBuffer := Value;
		1744	end;
		1745
		1746	procedure TSoundCaptureStream.Start;
		1747	var
		1748	dscbd: TDSCBufferDesc;
		1749	begin
		1750	Stop;
		1751	try
		1752	FCapturing := True;
		1753
		1754	FormatSize := SizeOf(TWaveFormatEx);
		1755	with FSupportedFormats[CaptureFormat] do
		1756	MakePCMWaveFormatEx(Format^, SamplesPerSec, BitsPerSample, Channels);
		1757
		1758	FBufferSize := Max(MulDiv(Format^.nAvgBytesPerSec, FBufferLength, 1000), 8000);
		1759
		1760	FillChar(dscbd, SizeOf(dscbd), 0);
		1761	dscbd.dwSize := SizeOf(dscbd);
		1762	dscbd.dwBufferBytes := FBufferSize;
		1763	dscbd.lpwfxFormat := Format;
		1764
		1765	if FCapture.CreateCaptureBuffer(dscbd, FBuffer, nil)<>DS_OK then
		1766	raise ESoundCaptureStreamError.CreateFmt(SCannotMade, [SDirectSoundCaptureBuffer]);
		1767
		1768	FBufferPos := 0;
		1769
		1770	FBuffer.Start(DSCBSTART_LOOPING);
		1771
		1772	if Assigned(FOnFilledBuffer) then
		1773	begin
		1774	FNotifyThread := TSoundCaptureStreamNotify.Create(Self);
		1775	FNotifyThread.Resume;
		1776	end;
		1777	except
		1778	Stop;
		1779	raise;
		1780	end;
		1781	end;
		1782
		1783	procedure TSoundCaptureStream.Stop;
		1784	begin
		1785	if FCapturing then
		1786	begin
		1787	FNotifyThread.Free;
		1788	FCapturing := False;
		1789	if FBuffer<>nil then
		1790	FBuffer.Stop;
		1791	FBuffer := nil;
		1792	end;
		1793	end;
		1794
		1795	{ TSoundEngine }
		1796
		1797	constructor TSoundEngine.Create(ADSound: TDirectSound);
		1798	begin
		1799	inherited Create;
		1800	FDSound := ADSound;
		1801	FEnabled := True;
		1802
		1803
		1804	FEffectList := TList.Create;
		1805	FTimer := TTimer.Create(nil);
		1806	FTimer.Interval := 500;
		1807	FTimer.OnTimer := TimerEvent;
		1808	end;
		1809
		1810	destructor TSoundEngine.Destroy;
		1811	begin
		1812	Clear;
		1813	FTimer.Free;
		1814	FEffectList.Free;
		1815	inherited Destroy;
		1816	end;
		1817
		1818	procedure TSoundEngine.Clear;
		1819	var
		1820	i: Integer;
		1821	begin
		1822	for i:=EffectCount-1 downto 0 do
		1823	Effects[i].Free;
		1824	FEffectList.Clear;
		1825	end;
		1826
		1827	procedure TSoundEngine.EffectFile(const Filename: string; Loop, Wait: Boolean);
		1828	var
		1829	Stream : TFileStream;
		1830	begin
		1831	Stream :=TFileStream.Create(Filename, fmOpenRead);
		1832	try
		1833	EffectStream(Stream, Loop, Wait);
		1834	finally
		1835	Stream.Free;
		1836	end;
		1837	end;
		1838
		1839	procedure TSoundEngine.EffectStream(Stream: TStream; Loop, Wait: Boolean);
		1840	var
		1841	Wave: TWave;
		1842	begin
		1843	Wave := TWave.Create;
		1844	try
		1845	Wave.LoadfromStream(Stream);
		1846	EffectWave(Wave, Loop, Wait);
		1847	finally
		1848	Wave.Free;
		1849	end;
		1850	end;
		1851
		1852	procedure TSoundEngine.EffectWave(Wave: TWave; Loop, Wait: Boolean);
		1853	var
		1854	Buffer: TDirectSoundBuffer;
		1855	begin
		1856	if not FEnabled then Exit;
		1857
		1858	if Wait then
		1859	begin
		1860	Buffer := TDirectSoundBuffer.Create(FDSound);
		1861	try
		1862	Buffer.LoadFromWave(Wave);
		1863	Buffer.Play(False);
		1864	while Buffer.Playing do
		1865	Sleep(1);
		1866	finally
		1867	Buffer.Free;
		1868	end;
		1869	end else
		1870	begin
		1871	Buffer := TDirectSoundBuffer.Create(FDSound);
		1872	try
		1873	Buffer.LoadFromWave(Wave);
		1874	Buffer.Play(Loop);
		1875	except
		1876	Buffer.Free;
		1877	raise;
		1878	end;
		1879	FEffectList.Add(Buffer);
		1880	end;
		1881	end;
		1882
		1883	function TSoundEngine.GetEffect(Index: Integer): TDirectSoundBuffer;
		1884	begin
		1885	Result := TDirectSoundBuffer(FEffectList[Index]);
		1886	end;
		1887
		1888	function TSoundEngine.GetEffectCount: Integer;
		1889	begin
		1890	Result := FEffectList.Count;
		1891	end;
		1892
		1893	procedure TSoundEngine.SetEnabled(Value: Boolean);
		1894	var
		1895	i: Integer;
		1896	begin
		1897	for i:=EffectCount-1 downto 0 do
		1898	Effects[i].Free;
		1899	FEffectList.Clear;
		1900
		1901	FEnabled := Value;
		1902	FTimer.Enabled := Value;
		1903	end;
		1904
		1905	procedure TSoundEngine.TimerEvent(Sender: TObject);
		1906	var
		1907	i: Integer;
		1908	begin
		1909	for i:=EffectCount-1 downto 0 do
		1910	if not TDirectSoundBuffer(FEffectList[i]).Playing then
		1911	begin
		1912	TDirectSoundBuffer(FEffectList[i]).Free;
		1913	FEffectList.Delete(i);
		1914	end;
		1915	end;
		1916
		1917	{ TCustomDXSound }
		1918
		1919	type
		1920	TDXSoundDirectSound = class(TDirectSound)
		1921	private
		1922	FDXSound: TCustomDXSound;
		1923	protected
		1924	procedure DoRestoreBuffer; override;
		1925	end;
		1926
		1927	procedure TDXSoundDirectSound.DoRestoreBuffer;
		1928	begin
		1929	inherited DoRestoreBuffer;
		1930	FDXSound.Restore;
		1931	end;
		1932
		1933	constructor TCustomDXSound.Create(AOwner: TComponent);
		1934	begin
		1935	FNotifyEventList := TList.Create;
		1936	inherited Create(AOwner);
		1937	FAutoInitialize := True;
		1938	Options := [];
		1939	end;
		1940
		1941	destructor TCustomDXSound.Destroy;
		1942	begin
		1943	Finalize;
		1944	NotifyEventList(dsntDestroying);
		1945	FNotifyEventList.Free;
		1946	inherited Destroy;
		1947	end;
		1948
		1949	type
		1950	PDXSoundNotifyEvent = ^TDXSoundNotifyEvent;
		1951
		1952	procedure TCustomDXSound.RegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);
		1953	var
		1954	Event: PDXSoundNotifyEvent;
		1955	begin
		1956	UnRegisterNotifyEvent(NotifyEvent);
		1957
		1958	New(Event);
		1959	Event^ := NotifyEvent;
		1960	FNotifyEventList.Add(Event);
		1961
		1962	if Initialized then
		1963	begin
		1964	NotifyEvent(Self, dsntInitialize);
		1965	NotifyEvent(Self, dsntRestore);
		1966	end;
		1967	end;
		1968
		1969	procedure TCustomDXSound.UnRegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);
		1970	var
		1971	Event: PDXSoundNotifyEvent;
		1972	i: Integer;
		1973	begin
		1974	for i:=0 to FNotifyEventList.Count-1 do
		1975	begin
		1976	Event := FNotifyEventList[i];
		1977	if (TMethod(Event^).Code = TMethod(NotifyEvent).Code) and
		1978	(TMethod(Event^).Data = TMethod(NotifyEvent).Data) then
		1979	begin
		1980	Dispose(Event);
		1981	FNotifyEventList.Delete(i);
		1982
		1983	if Initialized then
		1984	NotifyEvent(Self, dsntFinalize);
		1985
		1986	Break;
		1987	end;
		1988	end;
		1989	end;
		1990
		1991	procedure TCustomDXSound.NotifyEventList(NotifyType: TDXSoundNotifyType);
		1992	var
		1993	i: Integer;
		1994	begin
		1995	for i:=FNotifyEventList.Count-1 downto 0 do
		1996	PDXSoundNotifyEvent(FNotifyEventList[i])^(Self, NotifyType);
		1997	end;
		1998
		1999	procedure TCustomDXSound.FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
		2000	begin
		2001	case Message.Msg of
		2002	WM_CREATE:
		2003	begin
		2004	DefWindowProc(Message);
		2005	SetForm(FForm);
		2006	Exit;
		2007	end;
		2008	end;
		2009	DefWindowProc(Message);
		2010	end;
		2011
		2012	class function TCustomDXSound.Drivers: TDirectXDrivers;
		2013	begin
		2014	Result := EnumDirectSoundDrivers;
		2015	end;
		2016
		2017	procedure TCustomDXSound.DoFinalize;
		2018	begin
		2019	if Assigned(FOnFinalize) then FOnFinalize(Self);
		2020	end;
		2021
		2022	procedure TCustomDXSound.DoInitialize;
		2023	begin
		2024	if Assigned(FOnInitialize) then FOnInitialize(Self);
		2025	end;
		2026
		2027	procedure TCustomDXSound.DoInitializing;
		2028	begin
		2029	if Assigned(FOnInitializing) then FOnInitializing(Self);
		2030	end;
		2031
		2032	procedure TCustomDXSound.DoRestore;
		2033	begin
		2034	if Assigned(FOnRestore) then FOnRestore(Self);
		2035	end;
		2036
		2037	procedure TCustomDXSound.Finalize;
		2038	begin
		2039	if FInternalInitialized then
		2040	begin
		2041	try
		2042	FSubClass.Free; FSubClass := nil;
		2043
		2044	try
		2045	if FCalledDoInitialize then
		2046	begin
		2047	FCalledDoInitialize := False;
		2048	DoFinalize;
		2049	end;
		2050	finally
		2051	NotifyEventList(dsntFinalize);
		2052	end;
		2053	finally
		2054	FInitialized := False;
		2055	FInternalInitialized := False;
		2056
		2057	SetOptions(FOptions);
		2058
		2059	FPrimary.Free; FPrimary := nil;
		2060	FDSound.Free; FDSound := nil;
		2061	end;
		2062	end;
		2063	end;
		2064
		2065	procedure TCustomDXSound.Initialize;
		2066	const
		2067	PrimaryDesc: TDSBufferDesc = (
		2068	dwSize: SizeOf (PrimaryDesc);
		2069	dwFlags: DSBCAPS_PRIMARYBUFFER);
		2070	var
		2071	Component: TComponent;
		2072	begin
		2073	Finalize;
		2074
		2075	Component := Owner;
		2076	while (Component<>nil) and (not (Component is TCustomForm)) do
		2077	Component := Component.Owner;
		2078	if Component=nil then
		2079	raise EDXSoundError.Create(SNoForm);
		2080
		2081	NotifyEventList(dsntInitializing);
		2082	DoInitializing;
		2083
		2084	FInternalInitialized := True;
		2085	try
		2086	{ DirectSound initialization. }
		2087	FDSound := TDXSoundDirectSound.Create(Driver);
		2088	TDXSoundDirectSound(FDSound).FDXSound := Self;
		2089
		2090	FDSound.FGlobalFocus := soGlobalFocus in FNowOptions;
		2091
		2092	{ Primary buffer made. }
		2093	FPrimary := TDirectSoundBuffer.Create(FDSound);
		2094	if not FPrimary.CreateBuffer(PrimaryDesc) then
		2095	raise EDXSoundError.CreateFmt(SCannotMade, [SDirectSoundPrimaryBuffer]);
		2096
		2097	FInitialized := True;
		2098
		2099	SetForm(TCustomForm(Component));
		2100	except
		2101	Finalize;
		2102	raise;
		2103	end;
		2104
		2105	NotifyEventList(dsntInitialize);
		2106
		2107	FCalledDoInitialize := True; DoInitialize;
		2108
		2109	Restore;
		2110	end;
		2111
		2112	procedure TCustomDXSound.Loaded;
		2113	begin
		2114	inherited Loaded;
		2115
		2116	if FAutoInitialize and (not (csDesigning in ComponentState)) then
		2117	begin
		2118	try
		2119	Initialize;
		2120	except
		2121	on E: EDirectSoundError do ;
		2122	else raise;
		2123	end;
		2124	end;
		2125	end;
		2126
		2127	procedure TCustomDXSound.Restore;
		2128	begin
		2129	if FInitialized then
		2130	begin
		2131	NotifyEventList(dsntRestore);
		2132	DoRestore;
		2133	end;
		2134	end;
		2135
		2136	procedure TCustomDXSound.SetDriver(Value: PGUID);
		2137	begin
		2138	if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
		2139	begin
		2140	FDriverGUID := Value^;
		2141	FDriver := @FDriverGUID;
		2142	end else
		2143	FDriver := Value;
		2144	end;
		2145
		2146	procedure TCustomDXSound.SetForm(Value: TCustomForm);
		2147	var
		2148	Level: Integer;
		2149	begin
		2150	FForm := Value;
		2151
		2152	FSubClass.Free;
		2153	FSubClass := TControlSubClass.Create(FForm, FormWndProc);
		2154
		2155	if FInitialized then
		2156	begin
		2157	if soExclusive in FNowOptions then
		2158	Level := DSSCL_EXCLUSIVE
		2159	else
		2160	Level := DSSCL_NORMAL;
		2161
		2162	FDSound.DXResult := FDSound.ISound.SetCooperativeLevel(FForm.Handle, Level);
		2163	end;
		2164	end;
		2165
		2166	procedure TCustomDXSound.SetOptions(Value: TDXSoundOptions);
		2167	const
		2168	DXSoundOptions = [soGlobalFocus, soStickyFocus, soExclusive];
		2169	InitOptions: TDXSoundOptions = [soExclusive];
		2170	var
		2171	OldOptions: TDXSoundOptions;
		2172	begin
		2173	FOptions := Value;
		2174
		2175	if Initialized then
		2176	begin
		2177	OldOptions := FNowOptions;
		2178
		2179	FNowOptions := (FNowOptions - (DXSoundOptions - InitOptions)) +
		2180	(Value - InitOptions);
		2181
		2182	FDSound.FGlobalFocus := soGlobalFocus in FNowOptions;
		2183	FDSound.FStickyFocus := soStickyFocus in FNowOptions;
		2184	end else
		2185	FNowOptions := FOptions;
		2186	end;
		2187
		2188	{ TWaveCollectionItem }
		2189
		2190	constructor TWaveCollectionItem.Create(Collection: TCollection);
		2191	begin
		2192	inherited Create(Collection);
		2193	FWave := TWave.Create;
		2194	FBufferList := TList.Create;
		2195	end;
		2196
		2197	destructor TWaveCollectionItem.Destroy;
		2198	begin
		2199	Finalize;
		2200	FWave.Free;
		2201	FBufferList.Free;
		2202	inherited Destroy;
		2203	end;
		2204
		2205	procedure TWaveCollectionItem.Assign(Source: TPersistent);
		2206	var
		2207	PrevInitialized: Boolean;
		2208	begin
		2209	if Source is TWaveCollectionItem then
		2210	begin
		2211	PrevInitialized := Initialized;
		2212	Finalize;
		2213
		2214	FLooped := TWaveCollectionItem(Source).FLooped;
		2215	Name := TWaveCollectionItem(Source).Name;
		2216	FMaxPlayingCount := TWaveCollectionItem(Source).FMaxPlayingCount;
		2217
		2218	FFrequency := TWaveCollectionItem(Source).FFrequency;
		2219	FPan := TWaveCollectionItem(Source).FPan;
		2220	FVolume := TWaveCollectionItem(Source).FVolume;
		2221
		2222	FWave.Assign(TWaveCollectionItem(Source).FWave);
		2223
		2224	if PrevInitialized then
		2225	Restore;
		2226	end else
		2227	inherited Assign(Source);
		2228	end;
		2229
		2230	function TWaveCollectionItem.GetBuffer: TDirectSoundBuffer;
		2231	begin
		2232	if FInitialized and (FBuffer=nil) then
		2233	Restore;
		2234	Result := FBuffer;
		2235	end;
		2236
		2237	function TWaveCollectionItem.GetWaveCollection: TWaveCollection;
		2238	begin
		2239	Result := Collection as TWaveCollection;
		2240	end;
		2241
		2242	procedure TWaveCollectionItem.Finalize;
		2243	var
		2244	i: Integer;
		2245	begin
		2246	if not FInitialized then Exit;
		2247	FInitialized := False;
		2248
		2249	for i:=0 to FBufferList.Count-1 do
		2250	TDirectSoundBuffer(FBufferList[i]).Free;
		2251	FBufferList.Clear;
		2252	FBuffer.Free; FBuffer := nil;
		2253	end;
		2254
		2255	procedure TWaveCollectionItem.Initialize;
		2256	begin
		2257	Finalize;
		2258	FInitialized := WaveCollection.Initialized;
		2259	end;
		2260
		2261	function TWaveCollectionItem.CreateBuffer: TDirectSoundBuffer;
		2262	begin
		2263	Result := nil;
		2264	if GetBuffer=nil then Exit;
		2265
		2266	Result := TDirectSoundBuffer.Create(WaveCollection.DXSound.DSound);
		2267	try
		2268	Result.Assign(GetBuffer);
		2269	except
		2270	Result.Free;
		2271	raise;
		2272	end;
		2273	end;
		2274
		2275	procedure TWaveCollectionItem.Play(Wait: Boolean);
		2276	var
		2277	NewBuffer: TDirectSoundBuffer;
		2278	i: Integer;
		2279	begin
		2280	if not FInitialized then Exit;
		2281
		2282	if FLooped then
		2283	begin
		2284	GetBuffer.Stop;
		2285	GetBuffer.Position := 0;
		2286	GetBuffer.Play(True);
		2287	end else
		2288	begin
		2289	NewBuffer := nil;
		2290	for i:=0 to FBufferList.Count-1 do
		2291	if not TDirectSoundBuffer(FBufferList[i]).Playing then
		2292	begin
		2293	NewBuffer := FBufferList[i];
		2294	Break;
		2295	end;
		2296
		2297	if NewBuffer=nil then
		2298	begin
		2299	if FMaxPlayingCount=0 then
		2300	begin
		2301	NewBuffer := CreateBuffer;
		2302	if NewBuffer=nil then Exit;
		2303
		2304	FBufferList.Add(NewBuffer);
		2305	end else
		2306	begin
		2307	if FBufferList.Count<FMaxPlayingCount then
		2308	begin
		2309	NewBuffer := CreateBuffer;
		2310	if NewBuffer=nil then Exit;
		2311
		2312	FBufferList.Add(NewBuffer);
		2313	end else
		2314	begin
		2315	NewBuffer := FBufferList[0];
		2316	FBufferList.Move(0, FBufferList.Count-1);
		2317	end;
		2318	end;
		2319	end;
		2320
		2321	NewBuffer.Stop;
		2322	NewBuffer.Position := 0;
		2323	NewBuffer.Frequency := FFrequency;
		2324	NewBuffer.Pan := FPan;
		2325	NewBuffer.Volume := FVolume;
		2326	NewBuffer.Play(False);
		2327
		2328	if Wait then
		2329	begin
		2330	while NewBuffer.Playing do
		2331	Sleep(10);
		2332	end;
		2333	end;
		2334	end;
		2335
		2336	procedure TWaveCollectionItem.Restore;
		2337	begin
		2338	if FWave.Size=0 then Exit;
		2339
		2340	if not FInitialized then
		2341	begin
		2342	if WaveCollection.Initialized then
		2343	Initialize;
		2344	if not FInitialized then Exit;
		2345	end;
		2346
		2347	if FBuffer=nil then
		2348	FBuffer := TDirectSoundBuffer.Create(WaveCollection.DXSound.DSound);
		2349
		2350	FBuffer.LoadFromWave(FWave);
		2351	FBuffer.Frequency := FFrequency;
		2352	FBuffer.Pan := FPan;
		2353	FBuffer.Volume := FVolume;
		2354	end;
		2355
		2356	procedure TWaveCollectionItem.Stop;
		2357	var
		2358	i: Integer;
		2359	begin
		2360	if not FInitialized then Exit;
		2361
		2362	FBuffer.Stop;
		2363	for i:=0 to FBufferList.Count-1 do
		2364	TDirectSoundBuffer(FBufferList[i]).Stop;
		2365	end;
		2366
		2367	procedure TWaveCollectionItem.SetFrequency(Value: Integer);
		2368	begin
		2369	FFrequency := Value;
		2370	if FInitialized then
		2371	GetBuffer.Frequency := Value;
		2372	end;
		2373
		2374	procedure TWaveCollectionItem.SetLooped(Value: Boolean);
		2375	begin
		2376	if FLooped<>Value then
		2377	begin
		2378	Stop;
		2379	FLooped := Value;
		2380	end;
		2381	end;
		2382
		2383	procedure TWaveCollectionItem.SetMaxPlayingCount(Value: Integer);
		2384	var
		2385	i: Integer;
		2386	begin
		2387	if Value<0 then Value := 0;
		2388
		2389	if FMaxPlayingCount<>Value then
		2390	begin
		2391	FMaxPlayingCount := Value;
		2392
		2393	if FInitialized then
		2394	begin
		2395	for i:=0 to FBufferList.Count-1 do
		2396	TDirectSoundBuffer(FBufferList[i]).Free;
		2397	FBufferList.Clear;
		2398	end;
		2399	end;
		2400	end;
		2401
		2402	procedure TWaveCollectionItem.SetPan(Value: Integer);
		2403	begin
		2404	FPan := Value;
		2405	if FInitialized then
		2406	GetBuffer.Pan := Value;
		2407	end;
		2408
		2409	procedure TWaveCollectionItem.SetVolume(Value: Integer);
		2410	begin
		2411	FVolume := Value;
		2412	if FInitialized then
		2413	GetBuffer.Volume := Value;
		2414	end;
		2415
		2416	procedure TWaveCollectionItem.SetWave(Value: TWave);
		2417	begin
		2418	FWave.Assign(Value);
		2419	end;
		2420
		2421	{ TWaveCollection }
		2422
		2423	constructor TWaveCollection.Create(AOwner: TPersistent);
		2424	begin
		2425	inherited Create(TWaveCollectionItem);
		2426	FOwner := AOwner;
		2427	end;
		2428
		2429	function TWaveCollection.GetItem(Index: Integer): TWaveCollectionItem;
		2430	begin
		2431	Result := TWaveCollectionItem(inherited Items[Index]);
		2432	end;
		2433
		2434	function TWaveCollection.GetOwner: TPersistent;
		2435	begin
		2436	Result := FOwner;
		2437	end;
		2438
		2439	function TWaveCollection.Find(const Name: string): TWaveCollectionItem;
		2440	var
		2441	i: Integer;
		2442	begin
		2443	i := IndexOf(Name);
		2444	if i=-1 then
		2445	raise EWaveCollectionError.CreateFmt(SWaveNotFound, [Name]);
		2446	Result := Items[i];
		2447	end;
		2448
		2449	procedure TWaveCollection.Finalize;
		2450	var
		2451	i: Integer;
		2452	begin
		2453	for i:=0 to Count-1 do
		2454	Items[i].Finalize;
		2455	FDXSound := nil;
		2456	end;
		2457
		2458	procedure TWaveCollection.Initialize(DXSound: TCustomDXSound);
		2459	var
		2460	i: Integer;
		2461	begin
		2462	Finalize;
		2463	FDXSound := DXSound;
		2464	for i:=0 to Count-1 do
		2465	Items[i].Initialize;
		2466	end;
		2467
		2468	function TWaveCollection.Initialized: Boolean;
		2469	begin
		2470	Result := (FDXSound<>nil) and (FDXSound.Initialized);
		2471	end;
		2472
		2473	procedure TWaveCollection.Restore;
		2474	var
		2475	i: Integer;
		2476	begin
		2477	for i:=0 to Count-1 do
		2478	Items[i].Restore;
		2479	end;
		2480
		2481	type
		2482	TWaveCollectionComponent = class(TComponent)
		2483	private
		2484	FList: TWaveCollection;
		2485	published
		2486	property List: TWaveCollection read FList write FList;
		2487	end;
		2488
		2489	procedure TWaveCollection.LoadFromFile(const FileName: string);
		2490	var
		2491	Stream: TFileStream;
		2492	begin
		2493	Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
		2494	try
		2495	LoadFromStream(Stream);
		2496	finally
		2497	Stream.Free;
		2498	end;
		2499	end;
		2500
		2501	procedure TWaveCollection.LoadFromStream(Stream: TStream);
		2502	var
		2503	Component: TWaveCollectionComponent;
		2504	begin
		2505	Clear;
		2506	Component := TWaveCollectionComponent.Create(nil);
		2507	try
		2508	Component.FList := Self;
		2509	Stream.ReadComponentRes(Component);
		2510
		2511	if Initialized then
		2512	begin
		2513	Initialize(FDXSound);
		2514	Restore;
		2515	end;
		2516	finally
		2517	Component.Free;
		2518	end;
		2519	end;
		2520
		2521	procedure TWaveCollection.SaveToFile(const FileName: string);
		2522	var
		2523	Stream: TFileStream;
		2524	begin
		2525	Stream := TFileStream.Create(FileName, fmCreate);
		2526	try
		2527	SaveToStream(Stream);
		2528	finally
		2529	Stream.Free;
		2530	end;
		2531	end;
		2532
		2533	procedure TWaveCollection.SaveToStream(Stream: TStream);
		2534	var
		2535	Component: TWaveCollectionComponent;
		2536	begin
		2537	Component := TWaveCollectionComponent.Create(nil);
		2538	try
		2539	Component.FList := Self;
		2540	Stream.WriteComponentRes('DelphiXWaveCollection', Component);
		2541	finally
		2542	Component.Free;
		2543	end;
		2544	end;
		2545
		2546	{ TCustomDXWaveList }
		2547
		2548	constructor TCustomDXWaveList.Create(AOwner: TComponent);
		2549	begin
		2550	inherited Create(AOwner);
		2551	FItems := TWaveCollection.Create(Self);
		2552	end;
		2553
		2554	destructor TCustomDXWaveList.Destroy;
		2555	begin
		2556	DXSound := nil;
		2557	FItems.Free;
		2558	inherited Destroy;
		2559	end;
		2560
		2561	procedure TCustomDXWaveList.Notification(AComponent: TComponent; Operation: TOperation);
		2562	begin
		2563	inherited Notification(AComponent, Operation);
		2564	if (Operation=opRemove) and (DXSound=AComponent) then
		2565	DXSound := nil;
		2566	end;
		2567
		2568	procedure TCustomDXWaveList.DXSoundNotifyEvent(Sender: TCustomDXSound;
		2569	NotifyType: TDXSoundNotifyType);
		2570	begin
		2571	case NotifyType of
		2572	dsntDestroying: DXSound := nil;
		2573	dsntInitialize: FItems.Initialize(Sender);
		2574	dsntFinalize : FItems.Finalize;
		2575	dsntRestore : FItems.Restore;
		2576	end;
		2577	end;
		2578
		2579	procedure TCustomDXWaveList.SetDXSound(Value: TCustomDXSound);
		2580	begin
		2581	if FDXSound<>nil then
		2582	FDXSound.UnRegisterNotifyEvent(DXSoundNotifyEvent);
		2583
		2584	FDXSound := Value;
		2585
		2586	if FDXSound<>nil then
		2587	FDXSound.RegisterNotifyEvent(DXSoundNotifyEvent);
		2588	end;
		2589
		2590	procedure TCustomDXWaveList.SetItems(Value: TWaveCollection);
		2591	begin
		2592	FItems.Assign(Value);
		2593	end;
		2594
		2595	initialization
		2596	finalization
		2597	DirectSoundDrivers.Free;
		2598	DirectSoundCaptureDrivers.Free;
		2599	end.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DXSounds.pas – Rev 1