Subversion Repositories spacemission

Rev

Rev 1 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
1 daniel-mar 1
unit DXSounds;
2
 
3
interface
4
 
5
{$INCLUDE DelphiXcfg.inc}
6
 
7
uses
4 daniel-mar 8
  Windows, Messages, SysUtils, Classes, Controls, Forms, ExtCtrls, MMSystem, ActiveX,
9
  DXClass, DXWave, D3DUtils, {$IFDEF VER17UP} Types, {$ENDIF}
10
{$IFDEF StandardDX}
11
  DirectSound, DirectMusic;
12
{$ELSE}
13
  DirectX;
14
{$ENDIF}
1 daniel-mar 15
 
16
type
17
 
18
  {  EDirectSoundError  }
19
 
20
  EDirectSoundError = class(EDirectXError);
21
  EDirectSoundBufferError = class(EDirectSoundError);
22
 
23
  {  TDirectSound  }
24
 
25
  TDirectSoundBuffer = class;
26
 
27
  TDirectSound = class(TDirectX)
28
  private
29
    FBufferList: TList;
30
    FGlobalFocus: Boolean;
31
    FIDSound: IDirectSound;
32
    FInRestoreBuffer: Boolean;
33
    FStickyFocus: Boolean;
34
    function GetBuffer(Index: Integer): TDirectSoundBuffer;
35
    function GetBufferCount: Integer;
36
    function GetIDSound: IDirectSound;
37
    function GetISound: IDirectSound;
4 daniel-mar 38
  protected
1 daniel-mar 39
    procedure CheckBuffer(Buffer: TDirectSoundBuffer);
40
    procedure DoRestoreBuffer; virtual;
41
  public
42
    constructor Create(GUID: PGUID);
43
    destructor Destroy; override;
44
    class function Drivers: TDirectXDrivers;
45
    property BufferCount: Integer read GetBufferCount;
46
    property Buffers[Index: Integer]: TDirectSoundBuffer read GetBuffer;
47
    property IDSound: IDirectSound read GetIDSound;
48
    property ISound: IDirectSound read GetISound;
49
  end;
50
 
4 daniel-mar 51
  {  TD3DSParams  }
52
 
53
  TConeAngle = record
54
    Inside,Outside:DWord;
55
  end;
56
  TD3DSParams = class
57
  private
58
    FOwner: TDirectSoundBuffer;
59
 
60
    FDsb: TDS3DBUFFER;
61
 
62
    function GetPosition: TD3DVector;
63
    function GetVelocity: TD3DVector;
64
    function GetConeOrientation: TD3DVector;
65
    function GetConeAngle: TConeAngle;
66
    function GetConeOutsideVolume: Integer;
67
    function GetMinDistance: TD3DValue;
68
    function GetMaxDistance: TD3DValue;
69
    function GetRaw: TDS3DBuffer;
70
 
71
    procedure SetPosition(const v: TD3DVector);
72
    procedure SetVelocity(const v: TD3DVector);
73
    procedure SetConeOrientation(const v: TD3DVector);
74
    procedure SetConeAngle(const v: TConeAngle);
75
    procedure SetConeOutsideVolume(const v: Integer);
76
    procedure SetMinDistance(const v: TD3DValue);
77
    procedure SetMaxDistance(const v: TD3DValue);
78
    procedure SetRaw(const v: TDS3DBuffer);
79
 
80
    function CheckValidity: Boolean;
81
  public
82
    constructor Create(Owner: TDirectSoundBuffer);
83
    destructor Destroy; override;
84
    property Position: TD3DVector read getPosition write setPosition;
85
    property Velocity: TD3DVector read getVelocity write setVelocity;
86
    property ConeOrientation: TD3DVector read getConeOrientation write setConeOrientation;
87
    property ConeAngle: TConeAngle read getConeAngle write setConeAngle;
88
    property ConeOutsideVolume: Integer read getConeOutsideVolume write setConeOutsideVolume;
89
    property MinDistance: TD3DValue read getMinDistance write setMinDistance;
90
    property MaxDistance: TD3DValue read getMaxDistance write setMaxDistance;
91
    property RawParams: TDS3DBuffer read getRaw write setRaw;
92
    procedure Assign(Prms: TD3DSParams);
93
  end;
94
 
1 daniel-mar 95
  {  TDirectSoundBuffer  }
96
 
97
  TDirectSoundBuffer = class(TDirectX)
98
  private
99
    FDSound: TDirectSound;
100
    FIDSBuffer: IDirectSoundBuffer;
4 daniel-mar 101
    FIDS3DBuffer:IDirectSound3DBuffer;
102
    FD3DSParams: TD3DSParams;
1 daniel-mar 103
    FCaps: TDSBCaps;
104
    FFormat: PWaveFormatEx;
105
    FFormatSize: Integer;
106
    FLockAudioPtr1, FLockAudioPtr2: array[0..0] of Pointer;
107
    FLockAudioSize1, FLockAudioSize2: array[0..0] of DWORD;
108
    FLockCount: Integer;
4 daniel-mar 109
    FIsD3D: Boolean;
1 daniel-mar 110
    function GetBitCount: Longint;
111
    function GetFormat: PWaveFormatEx;
112
    function GetFrequency: Integer;
113
    function GetIDSBuffer: IDirectSoundBuffer;
114
    function GetIBuffer: IDirectSoundBuffer;
115
    function GetPlaying: Boolean;
116
    function GetPan: Integer;
117
    function GetPosition: Longint;
118
    function GetSize: Integer;
119
    function GetStatus: Integer;
120
    function GetVolume: Integer;
121
    procedure SetFrequency(Value: Integer);
122
    procedure SetIDSBuffer(Value: IDirectSoundBuffer);
123
    procedure SetPan(Value: Integer);
124
    procedure SetPosition(Value: Longint);
125
    procedure SetVolume(Value: Integer);
4 daniel-mar 126
    function GetIDS3DBuffer: IDirectSound3DBuffer;
127
    procedure SetIDS3DBuffer(const Value: IDirectSound3DBuffer);
128
    procedure SetD3DSParams(const Value: TD3DSParams);
1 daniel-mar 129
  protected
130
    procedure Check; override;
131
  public
132
    constructor Create(ADirectSound: TDirectSound);
133
    destructor Destroy; override;
134
    procedure Assign(Source: TPersistent); override;
135
    function CreateBuffer(const BufferDesc: TDSBufferDesc): Boolean;
136
    procedure LoadFromFile(const FileName: string);
137
    procedure LoadFromMemory(const Format: TWaveFormatEx;
138
      Data: Pointer; Size: Integer);
139
    procedure LoadFromStream(Stream: TStream);
140
    procedure LoadFromWave(Wave: TWave);
141
    function Lock(LockPosition, LockSize: Longint;
142
      var AudioPtr1: Pointer; var AudioSize1: Longint;
143
      var AudioPtr2: Pointer; var AudioSize2: Longint): Boolean;
4 daniel-mar 144
    function Play(Loop: Boolean{$IFNDEF VER100} = False{$ENDIF}): Boolean;
1 daniel-mar 145
    function Restore: Boolean;
146
    function SetFormat(const Format: TWaveFormatEx): Boolean;
4 daniel-mar 147
    procedure SetSize(const Format: TWaveFormatEx; Size: Integer; D3D: Boolean {$IFNDEF VER100}= False{$ENDIF});
1 daniel-mar 148
    procedure Stop;
149
    procedure UnLock;
150
    property BitCount: Longint read GetBitCount;
151
    property DSound: TDirectSound read FDSound;
152
    property Format: PWaveFormatEx read GetFormat;
153
    property FormatSize: Integer read FFormatSize;
154
    property Frequency: Integer read GetFrequency write SetFrequency;
155
    property IBuffer: IDirectSoundBuffer read GetIBuffer;
156
    property IDSBuffer: IDirectSoundBuffer read GetIDSBuffer write SetIDSBuffer;
4 daniel-mar 157
    property IDS3DBuffer: IDirectSound3DBuffer read GetIDS3DBuffer write SetIDS3DBuffer;
1 daniel-mar 158
    property Playing: Boolean read GetPlaying;
159
    property Pan: Integer read GetPan write SetPan;
4 daniel-mar 160
    property D3DSParams: TD3DSParams read FD3DSParams write SetD3DSParams;
161
    property IsD3D: Boolean read FIsD3D write FIsD3D default False;
1 daniel-mar 162
    property Position: Longint read GetPosition write SetPosition;
163
    property Size: Integer read GetSize;
164
    property Volume: Integer read GetVolume write SetVolume;
165
  end;
166
 
167
  {  EAudioStreamError  }
168
 
169
  EAudioStreamError = class(Exception);
170
 
171
  {  TAudioStream  }
172
 
173
  TAudioStream = class
174
  private
175
    FAutoUpdate: Boolean;
176
    FBuffer: TDirectSoundBuffer;
177
    FBufferLength: Integer;
178
    FBufferPos: DWORD;
179
    FPlayBufferPos: DWORD;
180
    FBufferSize: DWORD;
181
    FDSound: TDirectSound;
182
    FLooped: Boolean;
183
    FPlayedSize: Integer;
184
    FPlaying: Boolean;
185
    FPosition: Integer;
186
    FWaveStream: TCustomWaveStream;
187
    FWritePosition: Integer;
188
    FNotifyEvent: THandle;
189
    FNotifyThread: TThread;
190
    function GetFormat: PWaveFormatEX;
191
    function GetFormatSize: Integer;
192
    function GetFrequency: Integer;
193
    function GetPan: Integer;
194
    function GetPlayedSize: Integer;
195
    function GetSize: Integer;
196
    function GetVolume: Integer;
197
    function GetWriteSize: Integer;
198
    procedure SetAutoUpdate(Value: Boolean);
199
    procedure SetBufferLength(Value: Integer);
200
    procedure SetFrequency(Value: Integer);
201
    procedure SetLooped(Value: Boolean);
202
    procedure SetPan(Value: Integer);
203
    procedure SetPlayedSize(Value: Integer);
204
    procedure SetPosition(Value: Integer);
205
    procedure SetVolume(Value: Integer);
206
    procedure SetWaveStream(Value: TCustomWaveStream);
207
    procedure Update2(InThread: Boolean);
208
    procedure UpdatePlayedSize;
209
    function WriteWave(WriteSize: Integer): Integer;
210
  public
211
    constructor Create(ADirectSound: TDirectSound);
212
    destructor Destroy; override;
213
    procedure Play;
214
    procedure RecreateBuf;
215
    procedure Stop;
216
    procedure Update;
217
    property AutoUpdate: Boolean read FAutoUpdate write SetAutoUpdate;
218
    property BufferLength: Integer read FBufferLength write SetBufferLength;
219
    property Format: PWaveFormatEx read GetFormat;
220
    property FormatSize: Integer read GetFormatSize;
221
    property Frequency: Integer read GetFrequency write SetFrequency;
222
    property Pan: Integer read GetPan write SetPan;
223
    property PlayedSize: Integer read GetPlayedSize write SetPlayedSize;
224
    property Playing: Boolean read FPlaying;
225
    property Position: Integer read FPosition write SetPosition;
226
    property Looped: Boolean read FLooped write SetLooped;
227
    property Size: Integer read GetSize;
228
    property Volume: Integer read GetVolume write SetVolume;
229
    property WaveStream: TCustomWaveStream read FWaveStream write SetWaveStream;
230
  end;
4 daniel-mar 231
 
1 daniel-mar 232
  {  TAudioFileStream  }
233
 
234
  TAudioFileStream = class(TAudioStream)
235
  private
236
    FFileName: string;
237
    FWaveFileStream: TWaveFileStream;
238
    procedure SetFileName(const Value: string);
239
  public
240
    destructor Destroy; override;
241
    property FileName: string read FFileName write SetFileName;
242
  end;
243
 
244
  {  TSoundCaptureFormat  }
245
 
246
  TSoundCaptureFormat = class(TCollectionItem)
247
  private
248
    FBitsPerSample: Integer;
249
    FChannels: Integer;
250
    FSamplesPerSec: Integer;
251
  public
252
    property BitsPerSample: Integer read FBitsPerSample;
253
    property Channels: Integer read FChannels;
254
    property SamplesPerSec: Integer read FSamplesPerSec;
255
  end;
256
 
257
  {  TSoundCaptureFormats  }
258
 
259
  TSoundCaptureFormats = class(TCollection)
260
  private
261
    function GetItem(Index: Integer): TSoundCaptureFormat;
262
  public
263
    constructor Create;
264
    function IndexOf(ASamplesPerSec, ABitsPerSample, AChannels: Integer): Integer;
265
    property Items[Index: Integer]: TSoundCaptureFormat read GetItem; default;
266
  end;
267
 
268
  {  TSoundCaptureStream  }
269
 
270
  ESoundCaptureStreamError = class(EWaveStreamError);
271
 
272
  TSoundCaptureStream = class(TCustomWaveStream2)
273
  private
274
    FBuffer: IDirectSoundCaptureBuffer;
275
    FBufferLength: Integer;
276
    FBufferPos: DWORD;
277
    FBufferSize: DWORD;
278
    FCapture: IDirectSoundCapture;
279
    FCaptureFormat: Integer;
280
    FCapturing: Boolean;
281
    FNotifyEvent: THandle;
282
    FNotifyThread: TThread;
283
    FOnFilledBuffer: TNotifyEvent;
284
    FSupportedFormats: TSoundCaptureFormats;
285
    function GetReadSize: Integer;
286
    procedure SetBufferLength(Value: Integer);
287
    procedure SetOnFilledBuffer(Value: TNotifyEvent);
288
  protected
289
    procedure DoFilledBuffer; virtual;
290
    function GetFilledSize: Integer; override;
291
    function ReadWave(var Buffer; Count: Integer): Integer; override;
292
  public
293
    constructor Create(GUID: PGUID);
294
    destructor Destroy; override;
295
    class function Drivers: TDirectXDrivers;
296
    procedure Start;
297
    procedure Stop;
298
    property BufferLength: Integer read FBufferLength write SetBufferLength;
299
    property CaptureFormat: Integer read FCaptureFormat write FCaptureFormat;
300
    property Capturing: Boolean read FCapturing;
301
    property OnFilledBuffer: TNotifyEvent read FOnFilledBuffer write SetOnFilledBuffer;
302
    property SupportedFormats: TSoundCaptureFormats read FSupportedFormats;
303
  end;
304
 
305
  {  TSoundEngine  }
306
 
307
  TSoundEngine = class
308
  private
309
    FDSound: TDirectSound;
310
    FEffectList: TList;
311
    FEnabled: Boolean;
312
    FTimer: TTimer;
313
    function GetEffect(Index: Integer): TDirectSoundBuffer;
314
    function GetEffectCount: Integer;
315
    procedure SetEnabled(Value: Boolean);
316
    procedure TimerEvent(Sender: TObject);
317
  public
318
    constructor Create(ADSound: TDirectSound);
319
    destructor Destroy; override;
320
    procedure Clear;
321
    procedure EffectFile(const Filename: string; Loop, Wait: Boolean);
322
    procedure EffectStream(Stream: TStream; Loop, Wait: Boolean);
323
    procedure EffectWave(Wave: TWave; Loop, Wait: Boolean);
324
    property EffectCount: Integer read GetEffectCount;
325
    property Effects[Index: Integer]: TDirectSoundBuffer read GetEffect;
326
    property Enabled: Boolean read FEnabled write SetEnabled;
327
  end;
328
 
329
  {  EDXSoundError  }
330
 
331
  EDXSoundError = class(Exception);
332
 
333
  {  TCustomDXSound  }
334
 
335
  TCustomDXSound = class;
336
 
337
  TDXSoundOption = (soGlobalFocus, soStickyFocus, soExclusive);
338
  TDXSoundOptions = set of TDXSoundOption;
339
 
340
  TDXSoundNotifyType = (dsntDestroying, dsntInitializing, dsntInitialize, dsntFinalize, dsntRestore);
341
  TDXSoundNotifyEvent = procedure(Sender: TCustomDXSound; NotifyType: TDXSoundNotifyType) of object;
342
 
343
  TCustomDXSound = class(TComponent)
344
  private
345
    FAutoInitialize: Boolean;
346
    FCalledDoInitialize: Boolean;
347
    FDriver: PGUID;
348
    FDriverGUID: TGUID;
349
    FDSound: TDirectSound;
350
    FForm: TCustomForm;
351
    FInitialized: Boolean;
352
    FInternalInitialized: Boolean;
353
    FNotifyEventList: TList;
354
    FNowOptions: TDXSoundOptions;
355
    FOnFinalize: TNotifyEvent;
356
    FOnInitialize: TNotifyEvent;
357
    FOnInitializing: TNotifyEvent;
358
    FOnRestore: TNotifyEvent;
359
    FOptions: TDXSoundOptions;
360
    FPrimary: TDirectSoundBuffer;
361
    FSubClass: TControlSubClass;
362
    procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
363
    procedure NotifyEventList(NotifyType: TDXSoundNotifyType);
364
    procedure SetDriver(Value: PGUID);
365
    procedure SetForm(Value: TCustomForm);
366
    procedure SetOptions(Value: TDXSoundOptions);
367
  protected
368
    procedure DoFinalize; virtual;
369
    procedure DoInitialize; virtual;
370
    procedure DoInitializing; virtual;
371
    procedure DoRestore; virtual;
372
    procedure Loaded; override;
373
  public
374
    constructor Create(AOwner: TComponent); override;
375
    destructor Destroy; override;
376
    class function Drivers: TDirectXDrivers;
377
    procedure Finalize;
378
    procedure Initialize;
379
    procedure Restore;
380
    procedure RegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);
381
    procedure UnRegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);
382
 
383
    property AutoInitialize: Boolean read FAutoInitialize write FAutoInitialize;
384
    property Driver: PGUID read FDriver write SetDriver;
385
    property DSound: TDirectSound read FDSound;
386
    property Initialized: Boolean read FInitialized;
387
    property NowOptions: TDXSoundOptions read FNowOptions;
388
    property Primary: TDirectSoundBuffer read FPrimary;
389
    property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
390
    property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
391
    property OnInitializing: TNotifyEvent read FOnInitializing write FOnInitializing;
392
    property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
393
    property Options: TDXSoundOptions read FOptions write SetOptions;
394
  end;
395
 
396
  {  TDXSound  }
397
 
398
  TDXSound = class(TCustomDXSound)
399
  published
400
    property AutoInitialize;
401
    property Options;
402
    property OnFinalize;
403
    property OnInitialize;
404
    property OnInitializing;
405
    property OnRestore;
406
  end;
407
 
408
  {  EWaveCollectionError  }
409
 
410
  EWaveCollectionError = class(Exception);
411
 
412
  {  TWaveCollectionItem  }
413
 
414
  TWaveCollection = class;
415
 
416
  TWaveCollectionItem = class(THashCollectionItem)
417
  private
418
    FBuffer: TDirectSoundBuffer;
419
    FBufferList: TList;
420
    FFrequency: Integer;
421
    FInitialized: Boolean;
422
    FLooped: Boolean;
423
    FMaxPlayingCount: Integer;
424
    FPan: Integer;
425
    FVolume: Integer;
426
    FWave: TWave;
427
    function CreateBuffer: TDirectSoundBuffer;
428
    procedure Finalize;
429
    procedure Initialize;
430
    function GetBuffer: TDirectSoundBuffer;
431
    function GetWaveCollection: TWaveCollection;
432
    procedure SetFrequency(Value: Integer);
433
    procedure SetLooped(Value: Boolean);
434
    procedure SetMaxPlayingCount(Value: Integer);
435
    procedure SetPan(Value: Integer);
436
    procedure SetVolume(Value: Integer);
437
    procedure SetWave(Value: TWave);
4 daniel-mar 438
  protected
439
    function GetPlaying: boolean;
1 daniel-mar 440
  public
441
    constructor Create(Collection: TCollection); override;
442
    destructor Destroy; override;
443
    procedure Assign(Source: TPersistent); override;
444
    procedure Play(Wait: Boolean);
445
    procedure Restore;
446
    procedure Stop;
447
    property Frequency: Integer read FFrequency write SetFrequency;
448
    property Initialized: Boolean read FInitialized;
449
    property Pan: Integer read FPan write SetPan;
450
    property Volume: Integer read FVolume write SetVolume;
451
    property WaveCollection: TWaveCollection read GetWaveCollection;
4 daniel-mar 452
 
453
    property Playing: boolean read GetPlaying;
1 daniel-mar 454
  published
455
    property Looped: Boolean read FLooped write SetLooped;
456
    property MaxPlayingCount: Integer read FMaxPlayingCount write SetMaxPlayingCount;
457
    property Wave: TWave read FWave write SetWave;
458
  end;
459
 
460
  {  TWaveCollection  }
461
 
462
  TWaveCollection = class(THashCollection)
463
  private
464
    FDXSound: TCustomDXSound;
465
    FOwner: TPersistent;
466
    function GetItem(Index: Integer): TWaveCollectionItem;
467
    function Initialized: Boolean;
468
  protected
469
    function GetOwner: TPersistent; override;
470
  public
471
    constructor Create(AOwner: TPersistent);
472
    function Find(const Name: string): TWaveCollectionItem;
473
    procedure Finalize;
474
    procedure Initialize(DXSound: TCustomDXSound);
475
    procedure Restore;
476
    procedure LoadFromFile(const FileName: string);
477
    procedure LoadFromStream(Stream: TStream);
478
    procedure SaveToFile(const FileName: string);
479
    procedure SaveToStream(Stream: TStream);
480
    property DXSound: TCustomDXSound read FDXSound;
481
    property Items[Index: Integer]: TWaveCollectionItem read GetItem; default;
482
  end;
483
 
484
  {  TCustomDXWaveList  }
485
 
486
  TCustomDXWaveList = class(TComponent)
487
  private
488
    FDXSound: TCustomDXSound;
489
    FItems: TWaveCollection;
490
    procedure DXSoundNotifyEvent(Sender: TCustomDXSound; NotifyType: TDXSoundNotifyType);
491
    procedure SetDXSound(Value: TCustomDXSound);
492
    procedure SetItems(Value: TWaveCollection);
493
  protected
494
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
495
  public
496
    constructor Create(AOwner: TComponent); override;
497
    destructor Destroy; override;
498
    property DXSound: TCustomDXSound read FDXSound write SetDXSound;
499
    property Items: TWaveCollection read FItems write SetItems;
500
  end;
501
 
502
  {  TDXWaveList  }
503
 
504
  TDXWaveList = class(TCustomDXWaveList)
505
  published
506
    property DXSound;
507
    property Items;
508
  end;
509
 
4 daniel-mar 510
  {  EDXMusicError  }
511
 
512
  EDXMusicError = class(Exception);
513
 
514
  TMusicListCollection = class;
515
 
516
  {  TMusicListCollectionItem  }
517
 
518
  TMusicDataProp = class(TPersistent)
519
  private
520
    FMusicData: string;
521
    FMidiname: string;
522
    function GetMusicData: string;
523
    procedure SetMusicData(const Value: string);
524
  protected
525
    procedure DefineProperties(Filer: TFiler); override;
526
    procedure ReadMidiData(Stream: TStream);
527
    procedure WriteMidiData(Stream: TStream);
528
  public
529
    property MusicData: string read GetMusicData write SetMusicData;
530
  published
531
    property MidiName: string read FMidiname write FMidiname;
532
  end;
533
 
534
  TMusicListCollectionItem = class(THashCollectionItem)
535
  private
536
    { Private declarations }
537
    FDirectMusicPerformance: IDirectMusicPerformance;
538
    FDirectSound: IDirectSound;
539
    FDirectMusic: IDirectMusic;
540
    FDirectMusicLoader: IDirectMusicLoader;
541
    FDirectMusicSegment: IDirectMusicSegment;
542
    FMusicObjDesc: TDMus_ObjectDesc;
543
    FDirectMusicSegmentState: IDirectMusicSegmentState;
544
    FRepeats: Cardinal;
545
    FStartpoint: Integer;
546
    FDuration: Integer;
547
    // startpoint props in seconds these used to hold millisecond value
548
    FActualDuration: Integer;
549
    FActualStartPoint: Integer;
550
    FIsInitialized: Boolean;
551
    FMusicDataProp: TMusicDataProp;
552
    procedure SetDuration(const Value: integer);
553
    procedure SetRepeats(const Value: Cardinal);
554
    procedure SetStartPoint(const Value: integer);
555
    function GetMusicListCollection: TMusicListCollection;
556
  protected
557
    function GetDisplayName: string; override;
558
  public
559
    constructor Create(Collection: TCollection); override;
560
    destructor Destroy; override;
561
    function Size: Integer;
562
    procedure Play;
563
    function IsPlaying: Boolean;
564
    procedure Stop;
565
    procedure Load;
566
    procedure Init;
567
    procedure LoadFromFile(const MidiFileName: string);
568
    procedure SaveToFile(const MidiFileName: string);
569
    property MusicCollection: TMusicListCollection read GetMusicListCollection;
570
    property IsInitialized: Boolean read FIsInitialized write FIsInitialized;
571
  published
572
    property Name;
573
    property Repeats: Cardinal read Frepeats write SetRepeats;
574
    property Duration: integer read FDuration write SetDuration;
575
    property StartPoint: integer read FStartPoint write SetStartPoint;
576
    property Midi: TMusicDataProp read FMusicDataProp write FMusicDataProp;
577
  end;
578
 
579
  {  TMusicListCollection  }
580
 
581
  TMusicListCollection = class(THashCollection)
582
  private
583
    FOwner: TPersistent;
584
    FDirectSound: IDirectSound;
585
  protected
586
    function GetItem(Index: Integer): TMusicListCollectionItem;
587
    procedure SetItem(Index: Integer; Value: TMusicListCollectionItem);
588
    procedure Update(Item: TCollectionItem); override;
589
    function GetOwner: TPersistent; override;
590
  public
591
    constructor Create(AOwner: TComponent);
592
    function Add: TMusicListCollectionItem;
593
    function Find(const Name: string): TMusicListCollectionItem;
594
    procedure Restore;
595
    procedure LoadFromFile(const FileName: string);
596
    procedure LoadFromStream(Stream: TStream);
597
    procedure SaveToFile(const FileName: string);
598
    procedure SaveToStream(Stream: TStream);
599
{$IFDEF VER4UP}
600
    function Insert(Index: Integer): TMusicListCollectionItem;
601
{$ENDIF}
602
    property Items[Index: Integer]: TMusicListCollectionItem read GetItem write SetItem;
603
  published
604
  end;
605
 
606
  {  TDXMusic  }
607
 
608
  TDXMusic = class(TComponent)
609
  private
610
    FDXSound: TDXSound;
611
    FMidis: TMusicListCollection;
612
    procedure SetMidis(const value: TMusicListCollection);
613
    procedure SetDXSound(const Value: TDXSound);
614
  public
615
    constructor Create(AOwner: TComponent); override;
616
    destructor Destroy; override;
617
  published
618
    property DXSound: TDXSound read FDXSound write SetDXSound;
619
    property Midis: TMusicListCollection read FMidis write SetMidis;
620
  end;
621
 
1 daniel-mar 622
implementation
623
 
624
uses DXConsts;
625
 
4 daniel-mar 626
const
627
  dm_OK = 0;
628
 
1 daniel-mar 629
function DXDirectSoundCreate(lpGUID: PGUID; out lpDS: IDirectSound;
630
  pUnkOuter: IUnknown): HRESULT;
631
type
632
  TDirectSoundCreate = function(lpGUID: PGUID; out lplpDD: IDirectSound;
633
    pUnkOuter: IUnknown): HRESULT; stdcall;
634
begin
635
  Result := TDirectSoundCreate(DXLoadLibrary('DSound.dll', 'DirectSoundCreate'))
636
    (lpGUID, lpDS, pUnkOuter);
637
end;
638
 
639
function DXDirectSoundEnumerate(lpCallback: TDSEnumCallbackA;
4 daniel-mar 640
  lpContext: Pointer): HRESULT;
1 daniel-mar 641
type
642
  TDirectSoundEnumerate = function(lpCallback: TDSEnumCallbackA;
643
    lpContext: Pointer): HRESULT; stdcall;
644
begin
645
  Result := TDirectSoundEnumerate(DXLoadLibrary('DSound.dll', 'DirectSoundEnumerateA'))
646
    (lpCallback, lpContext);
647
end;
648
 
649
function DXDirectSoundCaptureCreate(lpGUID: PGUID; out lplpDSC: IDirectSoundCapture;
650
  pUnkOuter: IUnknown): HRESULT;
651
type
652
  TDirectSoundCaptureCreate = function(lpGUID: PGUID; out lplpDD: IDirectSoundCapture;
653
    pUnkOuter: IUnknown): HRESULT; stdcall;
654
begin
655
  try
656
    Result := TDirectSoundCaptureCreate(DXLoadLibrary('DSound.dll', 'DirectSoundCaptureCreate'))
657
      (lpGUID, lplpDSC, pUnkOuter);
658
  except
659
    raise EDirectXError.Create(SSinceDirectX5);
660
  end;
661
end;
662
 
663
function DXDirectSoundCaptureEnumerate(lpCallback: TDSEnumCallbackA;
4 daniel-mar 664
  lpContext: Pointer): HRESULT;
1 daniel-mar 665
type
666
  TDirectSoundCaptureEnumerate = function(lpCallback: TDSEnumCallbackA;
667
    lpContext: Pointer): HRESULT; stdcall;
668
begin
669
  try
670
    Result := TDirectSoundCaptureEnumerate(DXLoadLibrary('DSound.dll', 'DirectSoundCaptureEnumerateA'))
671
      (lpCallback, lpContext);
672
  except
673
    raise EDirectXError.Create(SSinceDirectX5);
674
  end;
675
end;
676
 
677
var
678
  DirectSoundDrivers: TDirectXDrivers;
679
  DirectSoundCaptureDrivers: TDirectXDrivers;
680
 
4 daniel-mar 681
function EnumDirectSoundDrivers_DSENUMCALLBACK(lpGuid: PGUID; lpstrDescription: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF};
682
  lpstrModule: {$IFDEF UNICODE}LPCTSTR{$ELSE}LPCSTR{$ENDIF}; lpContext: Pointer): BOOL; stdcall;
1 daniel-mar 683
begin
684
  Result := True;
685
  with TDirectXDriver.Create(TDirectXDrivers(lpContext)) do
686
  begin
687
    Guid := lpGuid;
688
    Description := lpstrDescription;
689
    DriverName := lpstrModule;
690
  end;
691
end;
692
 
693
function EnumDirectSoundDrivers: TDirectXDrivers;
694
begin
4 daniel-mar 695
  if DirectSoundDrivers = nil then
1 daniel-mar 696
  begin
697
    DirectSoundDrivers := TDirectXDrivers.Create;
698
    try
699
      DXDirectSoundEnumerate(@EnumDirectSoundDrivers_DSENUMCALLBACK, DirectSoundDrivers);
700
    except
701
      DirectSoundDrivers.Free;
702
      raise;
703
    end;
704
  end;
705
 
706
  Result := DirectSoundDrivers;
707
end;
708
 
709
function EnumDirectSoundCaptureDrivers: TDirectXDrivers;
710
begin
4 daniel-mar 711
  if DirectSoundCaptureDrivers = nil then
1 daniel-mar 712
  begin
713
    DirectSoundCaptureDrivers := TDirectXDrivers.Create;
714
    try
715
      DXDirectSoundCaptureEnumerate(@EnumDirectSoundDrivers_DSENUMCALLBACK, DirectSoundCaptureDrivers);
716
    except
717
      DirectSoundCaptureDrivers.Free;
718
      raise;
719
    end;
720
  end;
721
 
722
  Result := DirectSoundCaptureDrivers;
723
end;
724
 
725
{  TDirectSound  }
726
 
727
constructor TDirectSound.Create(GUID: PGUID);
728
begin
729
  inherited Create;
730
  FBufferList := TList.Create;
731
 
4 daniel-mar 732
  if DXDirectSoundCreate(GUID, FIDSound, nil) <> DS_OK then
1 daniel-mar 733
    raise EDirectSoundError.CreateFmt(SCannotInitialized, [SDirectSound]);
734
end;
735
 
736
destructor TDirectSound.Destroy;
737
begin
4 daniel-mar 738
  while BufferCount > 0 do
739
    Buffers[BufferCount - 1].Free;
1 daniel-mar 740
  FBufferList.Free;
741
 
742
  FIDSound := nil;
743
  inherited Destroy;
744
end;
745
 
746
class function TDirectSound.Drivers: TDirectXDrivers;
747
begin
748
  Result := EnumDirectSoundDrivers;
749
end;
750
 
751
procedure TDirectSound.CheckBuffer(Buffer: TDirectSoundBuffer);
752
begin
753
  case Buffer.DXResult of
754
    DSERR_BUFFERLOST:
755
      begin
756
        if not FInRestoreBuffer then
757
        begin
758
          FInRestoreBuffer := True;
759
          try
760
            DoRestoreBuffer;
761
          finally
762
            FInRestoreBuffer := False;
763
          end;
764
        end;
765
      end;
766
  end;
767
end;
768
 
769
procedure TDirectSound.DoRestoreBuffer;
770
begin
771
end;
772
 
773
function TDirectSound.GetBuffer(Index: Integer): TDirectSoundBuffer;
774
begin
775
  Result := FBufferList[Index];
776
end;
777
 
778
function TDirectSound.GetBufferCount: Integer;
779
begin
780
  Result := FBufferList.Count;
781
end;
782
 
783
function TDirectSound.GetIDSound: IDirectSound;
784
begin
4 daniel-mar 785
  if Self <> nil then
1 daniel-mar 786
    Result := FIDSound
787
  else
788
    Result := nil;
789
end;
790
 
791
function TDirectSound.GetISound: IDirectSound;
792
begin
793
  Result := IDSound;
4 daniel-mar 794
  if Result = nil then
1 daniel-mar 795
    raise EDirectSoundError.CreateFmt(SNotMade, ['IDirectSound']);
796
end;
797
 
798
{  TDirectSoundBuffer  }
799
 
800
constructor TDirectSoundBuffer.Create(ADirectSound: TDirectSound);
801
begin
802
  inherited Create;
4 daniel-mar 803
  FIsD3D := False;
1 daniel-mar 804
  FDSound := ADirectSound;
4 daniel-mar 805
  FIDS3DBuffer := nil;
1 daniel-mar 806
  FDSound.FBufferList.Add(Self);
807
end;
808
 
809
destructor TDirectSoundBuffer.Destroy;
810
begin
811
  IDSBuffer := nil;
4 daniel-mar 812
  IDS3DBuffer := nil;
1 daniel-mar 813
  FDSound.FBufferList.Remove(Self);
814
  inherited Destroy;
815
end;
816
 
817
procedure TDirectSoundBuffer.Assign(Source: TPersistent);
818
var
819
  TempBuffer: IDirectSoundBuffer;
820
begin
4 daniel-mar 821
  if Source = nil then
1 daniel-mar 822
    IDSBuffer := nil
4 daniel-mar 823
  else
824
  if Source is TWave then
1 daniel-mar 825
    LoadFromWave(TWave(Source))
4 daniel-mar 826
  else
827
  if Source is TDirectSoundBuffer then
1 daniel-mar 828
  begin
4 daniel-mar 829
    if TDirectSoundBuffer(Source).IDSBuffer = nil then
1 daniel-mar 830
      IDSBuffer := nil
4 daniel-mar 831
    else
832
    begin
833
      FDSound.DXResult := FDSound.ISound.DuplicateSoundBuffer(TDirectSoundBuffer(Source).IDSBuffer, TempBuffer);
834
      if FDSound.DXResult = DS_OK then
1 daniel-mar 835
      begin
836
        IDSBuffer := TempBuffer;
837
      end;
838
    end;
4 daniel-mar 839
 
840
    if FIsD3D then
841
      if TDirectSoundBuffer(Source).IDS3DBuffer = nil then
842
        IDS3DBuffer := nil
843
      else
844
      begin
845
        FDSound.DXResult := FDSound.ISound.QueryInterface(IID_IDirectSound3DBuffer, FIDS3DBuffer);
846
        if FDSound.DXResult = DS_OK then
847
          FD3DSParams := TDirectSoundBuffer(Source).FD3DSParams;
848
      end;
849
 
850
  end
851
  else
1 daniel-mar 852
    inherited Assign(Source);
853
end;
854
 
855
procedure TDirectSoundBuffer.Check;
856
begin
857
  FDSound.CheckBuffer(Self);
858
end;
859
 
860
function TDirectSoundBuffer.CreateBuffer(const BufferDesc: TDSBufferDesc): Boolean;
861
var
862
  TempBuffer: IDirectSoundBuffer;
863
begin
864
  IDSBuffer := nil;
865
 
866
  FDSound.DXResult := FDSound.ISound.CreateSoundBuffer(BufferDesc, TempBuffer, nil);
867
  FDXResult := FDSound.DXResult;
4 daniel-mar 868
  Result := DXResult = DS_OK;
1 daniel-mar 869
  if Result then
870
    IDSBuffer := TempBuffer;
871
end;
872
 
873
function TDirectSoundBuffer.GetBitCount: Longint;
874
begin
875
  Result := Format.wBitsPerSample;
876
end;
877
 
878
function TDirectSoundBuffer.GetFormat: PWaveFormatEx;
879
begin
880
  GetIBuffer;
881
  Result := FFormat;
882
end;
883
 
884
function TDirectSoundBuffer.GetFrequency: Integer;
885
begin
886
  DXResult := IBuffer.GetFrequency(DWORD(Result));
887
end;
888
 
4 daniel-mar 889
function TDirectSoundBuffer.GetIDS3DBuffer: IDirectSound3DBuffer;
890
begin
891
  if Self <> nil then
892
    Result := FIDS3DBuffer
893
  else
894
    Result := nil;
895
end;
896
 
1 daniel-mar 897
function TDirectSoundBuffer.GetIDSBuffer: IDirectSoundBuffer;
898
begin
4 daniel-mar 899
  if Self <> nil then
1 daniel-mar 900
    Result := FIDSBuffer
901
  else
902
    Result := nil;
903
end;
904
 
905
function TDirectSoundBuffer.GetIBuffer: IDirectSoundBuffer;
906
begin
907
  Result := IDSBuffer;
4 daniel-mar 908
  if Result = nil then
1 daniel-mar 909
    raise EDirectSoundBufferError.CreateFmt(SNotMade, ['IDirectSoundBuffer']);
910
end;
911
 
912
function TDirectSoundBuffer.GetPlaying: Boolean;
913
begin
4 daniel-mar 914
  Result := (GetStatus and (DSBSTATUS_PLAYING or DSBSTATUS_LOOPING)) <> 0;
1 daniel-mar 915
end;
916
 
917
function TDirectSoundBuffer.GetPan: Integer;
918
begin
919
  DXResult := IBuffer.GetPan(Longint(Result));
920
end;
921
 
922
function TDirectSoundBuffer.GetPosition: Longint;
4 daniel-mar 923
var
1 daniel-mar 924
  dwCurrentWriteCursor: Longint;
925
begin
4 daniel-mar 926
  IBuffer.GetCurrentPosition(@DWORD(Result), @DWORD(dwCurrentWriteCursor));
1 daniel-mar 927
end;
928
 
929
function TDirectSoundBuffer.GetSize: Integer;
930
begin
931
  Result := FCaps.dwBufferBytes;
932
end;
933
 
934
function TDirectSoundBuffer.GetStatus: Integer;
935
begin
936
  DXResult := IBuffer.GetStatus(DWORD(Result));
937
end;
938
 
939
function TDirectSoundBuffer.GetVolume: Integer;
940
begin
941
  DXResult := IBuffer.GetVolume(Longint(Result));
942
end;
943
 
944
procedure TDirectSoundBuffer.LoadFromFile(const FileName: string);
945
var
4 daniel-mar 946
  Stream: TFileStream;
1 daniel-mar 947
begin
948
  Stream := TFileStream.Create(FileName, fmOpenRead);
949
  try
950
    LoadFromStream(Stream);
951
  finally
952
    Stream.Free;
953
  end;
954
end;
955
 
956
procedure TDirectSoundBuffer.LoadFromMemory(const Format: TWaveFormatEx;
957
  Data: Pointer; Size: Integer);
958
var
959
  Data1, Data2: Pointer;
960
  Data1Size, Data2Size: Longint;
961
begin
4 daniel-mar 962
  SetSize(Format, Size, FIsD3D);
1 daniel-mar 963
 
4 daniel-mar 964
  if Data <> nil then
1 daniel-mar 965
  begin
966
    if Lock(0, Size, Data1, Data1Size, Data2, Data2Size) then
967
    begin
968
      try
969
        Move(Data^, Data1^, Data1Size);
4 daniel-mar 970
        if Data2 <> nil then
971
          Move(Pointer(Longint(Data) + Data1Size)^, Data2^, Data2Size);
1 daniel-mar 972
      finally
973
        UnLock;
974
      end;
4 daniel-mar 975
    end
976
    else
1 daniel-mar 977
    begin
978
      FIDSBuffer := nil;
4 daniel-mar 979
      FIDS3DBuffer := nil;
1 daniel-mar 980
      raise EDirectSoundBufferError.CreateFmt(SCannotLock, [SDirectSoundBuffer]);
981
    end;
982
  end;
983
end;
984
 
985
procedure TDirectSoundBuffer.LoadFromStream(Stream: TStream);
4 daniel-mar 986
var
1 daniel-mar 987
  Wave: TWave;
988
begin
989
  Wave := TWave.Create;
990
  try
991
    Wave.LoadFromStream(Stream);
992
    LoadFromWave(Wave);
993
  finally
994
    Wave.Free;
995
  end;
996
end;
997
 
998
procedure TDirectSoundBuffer.LoadFromWave(Wave: TWave);
999
begin
1000
  LoadFromMemory(Wave.Format^, Wave.Data, Wave.Size);
1001
end;
1002
 
1003
function TDirectSoundBuffer.Lock(LockPosition, LockSize: Longint;
1004
  var AudioPtr1: Pointer; var AudioSize1: Longint;
1005
  var AudioPtr2: Pointer; var AudioSize2: Longint): Boolean;
1006
begin
1007
  Result := False;
4 daniel-mar 1008
  if IDSBuffer = nil then Exit;
1 daniel-mar 1009
 
4 daniel-mar 1010
  if FLockCount > High(FLockAudioPtr1) then Exit;
1 daniel-mar 1011
  DXResult := IBuffer.Lock(LockPosition, LockSize,
4 daniel-mar 1012
    {$IFNDEF DX7}@{$ENDIF}FLockAudioPtr1[FLockCount], {$IFNDEF DX7}@{$ENDIF}FLockAudioSize1[FLockCount],
1013
    {$IFNDEF DX7}@{$ENDIF}FLockAudioPtr2[FLockCount], {$IFNDEF DX7}@{$ENDIF}FLockAudioSize2[FLockCount], 0);
1014
  Result := DXResult = DS_OK;
1 daniel-mar 1015
 
1016
  if Result then
1017
  begin
1018
    AudioPtr1 := FLockAudioPtr1[FLockCount];
1019
    AudioPtr2 := FLockAudioPtr2[FLockCount];
1020
    AudioSize1 := FLockAudioSize1[FLockCount];
1021
    AudioSize2 := FLockAudioSize2[FLockCount];
1022
    Inc(FLockCount);
1023
  end;
1024
end;
1025
 
1026
function TDirectSoundBuffer.Play(Loop: Boolean): Boolean;
1027
begin
1028
  if Loop then
1029
    DXResult := IBuffer.Play(0, 0, DSBPLAY_LOOPING)
1030
  else
1031
    DXResult := IBuffer.Play(0, 0, 0);
4 daniel-mar 1032
  Result := DXResult = DS_OK;
1 daniel-mar 1033
end;
1034
 
1035
function TDirectSoundBuffer.Restore: Boolean;
1036
begin
1037
  DXResult := IBuffer.Restore;
4 daniel-mar 1038
  Result := DXResult = DS_OK;
1 daniel-mar 1039
end;
1040
 
4 daniel-mar 1041
procedure TDirectSoundBuffer.SetD3DSParams(const Value: TD3DSParams);
1042
begin
1043
  FD3DSParams.Assign(Value);
1044
end;
1045
 
1 daniel-mar 1046
function TDirectSoundBuffer.SetFormat(const Format: TWaveFormatEx): Boolean;
1047
begin
4 daniel-mar 1048
  DXResult := IBuffer.SetFormat(FFormat{$IFDEF DX7}^{$ENDIF});
1049
  Result := DXResult = DS_OK;
1 daniel-mar 1050
 
1051
  if Result then
1052
  begin
1053
    FreeMem(FFormat);
1054
    FFormat := nil;
1055
    FFormatSize := 0;
4 daniel-mar 1056
    if IBuffer.GetFormat(PWaveFormatEx(nil), 0, @DWORD(FFormatSize)) = DS_OK then
1 daniel-mar 1057
    begin
1058
      GetMem(FFormat, FFormatSize);
4 daniel-mar 1059
      IBuffer.GetFormat(FFormat, FFormatSize, nil);
1060
    end;
1 daniel-mar 1061
  end;
1062
end;
1063
 
1064
procedure TDirectSoundBuffer.SetFrequency(Value: Integer);
1065
begin
1066
  DXResult := IBuffer.SetFrequency(Value);
1067
end;
1068
 
4 daniel-mar 1069
procedure TDirectSoundBuffer.SetIDS3DBuffer(const Value: IDirectSound3DBuffer);
1070
begin
1071
  if FIDS3DBuffer = Value then Exit;
1072
 
1073
  FIDS3DBuffer := Value;
1074
  FillChar(FCaps, SizeOf(FCaps), 0);
1075
  FreeMem(FFormat);
1076
  FFormat := nil;
1077
  FFormatSize := 0;
1078
  FLockCount := 0;
1079
 
1080
  if FIDS3DBuffer <> nil then
1081
  begin
1082
    FCaps.dwSize := SizeOf(FCaps);
1083
    IBuffer.GetCaps(FCaps);
1084
 
1085
    if IBuffer.GetFormat(PWaveFormatEx(nil), 0, @DWORD(FFormatSize)) = DS_OK then
1086
    begin
1087
      GetMem(FFormat, FFormatSize);
1088
      IBuffer.GetFormat(FFormat, FFormatSize, nil);
1089
    end;
1090
  end;
1091
end;
1092
 
1 daniel-mar 1093
procedure TDirectSoundBuffer.SetIDSBuffer(Value: IDirectSoundBuffer);
1094
begin
4 daniel-mar 1095
  if FIDSBuffer = Value then Exit;
1 daniel-mar 1096
 
1097
  FIDSBuffer := Value;
1098
  FillChar(FCaps, SizeOf(FCaps), 0);
1099
  FreeMem(FFormat);
1100
  FFormat := nil;
1101
  FFormatSize := 0;
1102
  FLockCount := 0;
1103
 
4 daniel-mar 1104
  if FIDSBuffer <> nil then
1 daniel-mar 1105
  begin
1106
    FCaps.dwSize := SizeOf(FCaps);
1107
    IBuffer.GetCaps(FCaps);
1108
 
4 daniel-mar 1109
    if IBuffer.GetFormat(PWaveFormatEx(nil), 0, @DWORD(FFormatSize)) = DS_OK then
1 daniel-mar 1110
    begin
1111
      GetMem(FFormat, FFormatSize);
4 daniel-mar 1112
      IBuffer.GetFormat(FFormat, FFormatSize, nil);
1113
    end;
1 daniel-mar 1114
  end;
1115
end;
1116
 
1117
procedure TDirectSoundBuffer.SetPan(Value: Integer);
1118
begin
1119
  DXResult := IBuffer.SetPan(Value);
1120
end;
1121
 
1122
procedure TDirectSoundBuffer.SetPosition(Value: Longint);
1123
begin
1124
  DXResult := IBuffer.SetCurrentPosition(Value);
1125
end;
4 daniel-mar 1126
{$IFNDEF DX7}
1127
const
1128
  DSBCAPS_CTRLDEFAULT = DSBCAPS_CTRLFREQUENCY or DSBCAPS_CTRLPAN or DSBCAPS_CTRLVOLUME;
1129
{$ENDIF}
1 daniel-mar 1130
 
4 daniel-mar 1131
procedure TDirectSoundBuffer.SetSize(const Format: TWaveFormatEx; Size: Integer; D3D: Boolean {$IFNDEF VER100}= False{$ENDIF});
1 daniel-mar 1132
var
1133
  BufferDesc: TDSBufferDesc;
1134
begin
1135
  {  IDirectSoundBuffer made.  }
1136
  FillChar(BufferDesc, SizeOf(BufferDesc), 0);
4 daniel-mar 1137
 
1 daniel-mar 1138
  with BufferDesc do
1139
  begin
1140
    dwSize := SizeOf(TDSBufferDesc);
1141
    dwFlags := DSBCAPS_CTRLDEFAULT;
1142
    if DSound.FStickyFocus then
1143
      dwFlags := dwFlags or DSBCAPS_STICKYFOCUS
1144
    else if DSound.FGlobalFocus then
1145
      dwFlags := dwFlags or DSBCAPS_GLOBALFOCUS;
4 daniel-mar 1146
    if D3D then
1147
      dwFlags := DSBCAPS_STATIC + DSBCAPS_CTRLDEFAULT + DSBCAPS_CTRL3D - DSBCAPS_CTRLPAN;
1 daniel-mar 1148
    dwBufferBytes := Size;
1149
    lpwfxFormat := @Format;
1150
  end;
1151
 
1152
  if not CreateBuffer(BufferDesc) then
1153
    raise EDirectSoundBufferError.CreateFmt(SCannotMade, [SDirectSoundBuffer]);
1154
end;
1155
 
1156
procedure TDirectSoundBuffer.SetVolume(Value: Integer);
1157
begin
1158
  DXResult := IBuffer.SetVolume(Value);
1159
end;
1160
 
1161
procedure TDirectSoundBuffer.Stop;
1162
begin
1163
  DXResult := IBuffer.Stop;
1164
end;
1165
 
1166
procedure TDirectSoundBuffer.Unlock;
1167
begin
4 daniel-mar 1168
  if IDSBuffer = nil then Exit;
1169
  if FLockCount = 0 then Exit;
1 daniel-mar 1170
 
1171
  Dec(FLockCount);
1172
  DXResult := IBuffer.UnLock(FLockAudioPtr1[FLockCount], FLockAudioSize1[FLockCount],
1173
    FLockAudioPtr2[FLockCount], FLockAudioSize2[FLockCount]);
1174
end;
1175
 
4 daniel-mar 1176
{  TD3DSParams  }
1177
 
1178
function TD3DSParams.CheckValidity: Boolean;
1179
begin
1180
  Result := (FOwner <> nil) and (TDirectSoundBuffer(FOwner).IDS3DBuffer <> nil)
1181
end;
1182
 
1183
constructor TD3DSParams.Create(Owner: TDirectSoundBuffer);
1184
  {$IFDEF VER14UP}
1185
  function MakeD3DVector(x, y, z: TD3DValue): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
1186
  begin
1187
    Result.x := x;
1188
    Result.y := y;
1189
    Result.z := z;
1190
  end;
1191
  {$ENDIF}
1192
begin
1193
  inherited Create;
1194
  FOwner := Owner;
1195
  with FDsb do
1196
  begin
1197
    dwSize := SizeOf(TDS3DBuffer);
1198
    vPosition := MakeD3DVector(0, 0, 0);
1199
    vVelocity := MakeD3DVector(0, 0, 0);
1200
    dwInsideConeAngle := DS3D_DEFAULTCONEANGLE;
1201
    dwOutsideConeAngle := DS3D_DEFAULTCONEANGLE;
1202
    vConeOrientation := MakeD3DVector(0, 0, 0);
1203
    lConeoutsideVolume := DS3D_DEFAULTCONEOUTSIDEVOLUME;
1204
    flMinDistance := 5;
1205
    flMaxDistance := 100.0;
1206
    dwMode := DS3DMODE_NORMAL;
1207
  end;
1208
end;
1209
 
1210
destructor TD3DSParams.destroy;
1211
begin
1212
  inherited destroy;
1213
end;
1214
 
1215
function TD3DSParams.getPosition: TD3DVector;
1216
begin
1217
  if CheckValidity then
1218
  begin
1219
    FOwner.IDS3DBuffer.GetPosition(FDsb.vPosition);
1220
  end;
1221
  result := FDsb.vPosition;
1222
end;
1223
 
1224
function TD3DSParams.getVelocity: TD3DVector;
1225
begin
1226
  if CheckValidity then
1227
  begin
1228
    FOwner.IDS3DBuffer.GetVelocity(FDsb.vVelocity);
1229
  end;
1230
  result := FDsb.vVelocity;
1231
end;
1232
 
1233
function TD3DSParams.getConeOrientation: TD3DVector;
1234
begin
1235
  if CheckValidity then
1236
  begin
1237
    FOwner.IDS3DBuffer.GetConeOrientation(FDsb.vConeOrientation);
1238
  end;
1239
  result := FDsb.vConeOrientation;
1240
end;
1241
 
1242
function TD3DSParams.getConeAngle: TConeAngle;
1243
begin
1244
  if CheckValidity then
1245
  begin
1246
    FOwner.IDS3DBuffer.GetConeAngles(FDsb.dwInsideConeAngle, FDsb.dwOutsideConeAngle);
1247
  end;
1248
  with result do
1249
  begin
1250
    Inside := FDsb.dwInsideConeAngle;
1251
    OutSide := FDsb.dwOutsideConeAngle;
1252
  end;
1253
end;
1254
 
1255
function TD3DSParams.getConeOutsideVolume: Integer;
1256
begin
1257
  if CheckValidity then
1258
  begin
1259
    FOwner.IDS3DBuffer.GetConeOutsideVolume(FDsb.lConeOutsideVolume);
1260
  end;
1261
  result := FDsb.lConeOutsideVolume;
1262
end;
1263
 
1264
function TD3DSParams.getMinDistance: TD3DValue;
1265
begin
1266
  if CheckValidity then
1267
  begin
1268
    FOwner.IDS3DBuffer.GetMinDistance(FDsb.flMinDistance);
1269
  end;
1270
  result := FDsb.flMinDistance;
1271
end;
1272
 
1273
function TD3DSParams.getMaxDistance: TD3DValue;
1274
begin
1275
  if CheckValidity then
1276
  begin
1277
    FOwner.IDS3DBuffer.GetMaxDistance(FDsb.flMaxDistance);
1278
  end;
1279
  result := FDsb.flMaxDistance;
1280
end;
1281
 
1282
function TD3DSParams.getRaw: TDS3DBuffer;
1283
begin
1284
  if CheckValidity then
1285
  begin
1286
    FOwner.IDS3DBuffer.GetAllParameters(FDsb);
1287
  end;
1288
  result := FDsb;
1289
end;
1290
 
1291
 
1292
procedure TD3DSParams.setPosition(const v: TD3DVector);
1293
begin
1294
  if CheckValidity then
1295
  begin
1296
    FOwner.IDS3DBuffer.SetPosition(v.x, v.y, v.z, DS3D_IMMEDIATE);
1297
  end;
1298
  FDsb.vPosition := v;
1299
end;
1300
 
1301
procedure TD3DSParams.setVelocity(const v: TD3DVector);
1302
begin
1303
  if CheckValidity then
1304
  begin
1305
    FOwner.IDS3DBuffer.SetVelocity(v.x, v.y, v.z, DS3D_IMMEDIATE);
1306
  end;
1307
  FDsb.vVelocity := v;
1308
end;
1309
 
1310
procedure TD3DSParams.setConeOrientation(const v: TD3DVector);
1311
begin
1312
  if CheckValidity then
1313
  begin
1314
    FOwner.IDS3DBuffer.SetConeOrientation(v.x, v.y, v.z, DS3D_IMMEDIATE);
1315
  end;
1316
  FDsb.vConeOrientation := v;
1317
end;
1318
 
1319
procedure TD3DSParams.setConeAngle(const v: TConeAngle);
1320
begin
1321
  if CheckValidity then
1322
  begin
1323
    FOwner.IDS3DBuffer.SetConeAngles(v.Inside, v.Outside, DS3D_IMMEDIATE);
1324
  end;
1325
  FDsb.dwInsideConeAngle := v.Inside;
1326
  FDsb.dwInsideConeAngle := v.Outside;
1327
end;
1328
 
1329
procedure TD3DSParams.setConeOutsideVolume(const v: Integer);
1330
begin
1331
  if CheckValidity then
1332
  begin
1333
    FOwner.IDS3DBuffer.SetConeOutsideVolume(v, DS3D_IMMEDIATE);
1334
  end;
1335
  FDsb.lConeOutsideVolume := v;
1336
end;
1337
 
1338
procedure TD3DSParams.setMinDistance(const v: TD3DValue);
1339
begin
1340
  if CheckValidity then
1341
  begin
1342
    FOwner.IDS3DBuffer.SetMinDistance(v, DS3D_IMMEDIATE);
1343
  end;
1344
  FDsb.flMinDistance := v;
1345
end;
1346
 
1347
procedure TD3DSParams.setMaxDistance(const v: TD3DValue);
1348
begin
1349
  if CheckValidity then
1350
  begin
1351
    FOwner.IDS3DBuffer.SetMaxDistance(v, DS3D_IMMEDIATE);
1352
  end;
1353
  FDsb.flMaxDistance := v;
1354
end;
1355
 
1356
procedure TD3DSParams.setRaw(const v: TDS3DBuffer);
1357
begin
1358
  if CheckValidity then
1359
  begin
1360
    if FOwner.IDS3DBuffer.SetAllParameters(v, DS3D_IMMEDIATE) <> DS_OK then
1361
      {'Parameter is invalid for Params3D'};
1362
  end;
1363
  FDsb := v;
1364
end;
1365
 
1366
procedure TD3DSParams.Assign(Prms: TD3DSParams);
1367
begin
1368
  FDsb := Prms.RawParams;
1369
 
1370
  if CheckValidity then
1371
  begin
1372
    if FOwner.IDS3DBuffer.SetAllParameters(FDsb, DS3D_IMMEDIATE) <> DS_OK then
1373
      {'Parameter is invalid for Params3D'};
1374
  end;
1375
end;
1376
 
1 daniel-mar 1377
{  TAudioStream  }
1378
 
1379
type
1380
  TAudioStreamNotify = class(TThread)
1381
  private
1382
    FAudio: TAudioStream;
1383
    FSleepTime: Integer;
1384
    FStopOnTerminate: Boolean;
1385
    constructor Create(Audio: TAudioStream);
1386
    destructor Destroy; override;
1387
    procedure Execute; override;
1388
    procedure Update;
1389
    procedure ThreadTerminate(Sender: TObject);
1390
  end;
1391
 
1392
constructor TAudioStreamNotify.Create(Audio: TAudioStream);
1393
begin
1394
  FAudio := Audio;
1395
 
1396
  OnTerminate := ThreadTerminate;
1397
 
1398
  FAudio.FNotifyEvent := CreateEvent(nil, False, False, nil);
1399
  FAudio.FNotifyThread := Self;
1400
 
1401
  FSleepTime := Min(FAudio.FBufferLength div 4, 1000 div 20);
1402
  FStopOnTerminate := True;
1403
 
1404
  FreeOnTerminate := True;
1405
  inherited Create(False);
1406
end;
1407
 
1408
destructor TAudioStreamNotify.Destroy;
1409
begin
1410
  FreeOnTerminate := False;
1411
 
1412
  SetEvent(FAudio.FNotifyEvent);
1413
  inherited Destroy;
1414
  CloseHandle(FAudio.FNotifyEvent);
1415
 
1416
  FAudio.FNotifyThread := nil;
1417
end;
1418
 
1419
procedure TAudioStreamNotify.ThreadTerminate(Sender: TObject);
1420
begin
1421
  FAudio.FNotifyThread := nil;
1422
  if FStopOnTerminate then FAudio.Stop;
1423
end;
1424
 
1425
procedure TAudioStreamNotify.Execute;
1426
begin
4 daniel-mar 1427
  while WaitForSingleObject(FAudio.FNotifyEvent, FSleepTime) = WAIT_TIMEOUT do
1 daniel-mar 1428
    Synchronize(Update);
1429
end;
1430
 
1431
procedure TAudioStreamNotify.Update;
1432
begin
1433
  if not FAudio.Playing then
1434
  begin
1435
    SetEvent(FAudio.FNotifyEvent);
1436
    EXit;
1437
  end;
1438
 
1439
  try
1440
    FAudio.Update2(True);
1441
  except
1442
    on E: Exception do
1443
    begin
1444
      Application.HandleException(E);
1445
      SetEvent(FAudio.FNotifyEvent);
1446
    end;
1447
  end;
1448
end;
1449
 
1450
constructor TAudioStream.Create(ADirectSound: TDirectSound);
1451
begin
1452
  inherited Create;
1453
  FDSound := ADirectSound;
1454
  FAutoUpdate := True;
1455
  FBuffer := TDirectSoundBuffer.Create(FDSound);
1456
  FBufferLength := 1000;
1457
end;
1458
 
1459
destructor TAudioStream.Destroy;
1460
begin
1461
  Stop;
1462
  WaveStream := nil;
1463
  FBuffer.Free;
1464
  inherited Destroy;
1465
end;
1466
 
1467
function TAudioStream.GetFormat: PWaveFormatEX;
1468
begin
4 daniel-mar 1469
  if WaveStream = nil then
1 daniel-mar 1470
    raise EAudioStreamError.Create(SWaveStreamNotSet);
1471
  Result := WaveStream.Format;
1472
end;
1473
 
1474
function TAudioStream.GetFormatSize: Integer;
1475
begin
4 daniel-mar 1476
  if WaveStream = nil then
1 daniel-mar 1477
    raise EAudioStreamError.Create(SWaveStreamNotSet);
1478
  Result := WaveStream.FormatSize;
1479
end;
1480
 
1481
function TAudioStream.GetFrequency: Integer;
1482
begin
1483
  Result := FBuffer.Frequency;
1484
end;
1485
 
1486
function TAudioStream.GetPan: Integer;
1487
begin
1488
  Result := FBuffer.Pan;
1489
end;
1490
 
1491
function TAudioStream.GetPlayedSize: Integer;
1492
begin
1493
  if Playing then UpdatePlayedSize;
1494
  Result := FPlayedSize;
1495
end;
1496
 
1497
function TAudioStream.GetSize: Integer;
1498
begin
4 daniel-mar 1499
  if WaveStream <> nil then
1 daniel-mar 1500
    Result := WaveStream.Size
1501
  else
1502
    Result := 0;
1503
end;
1504
 
1505
function TAudioStream.GetVolume: Integer;
1506
begin
1507
  Result := FBuffer.Volume;
1508
end;
1509
 
1510
procedure TAudioStream.UpdatePlayedSize;
1511
var
1512
  PlayPosition, PlayedSize: DWORD;
1513
begin
1514
  PlayPosition := FBuffer.Position;
1515
 
1516
  if FPlayBufferPos <= PlayPosition then
1517
  begin
1518
    PlayedSize := PlayPosition - FPlayBufferPos
1519
  end else
1520
  begin
1521
    PlayedSize := PlayPosition + (FBufferSize - FPlayBufferPos);
1522
  end;
1523
 
1524
  Inc(FPlayedSize, PlayedSize);
1525
 
1526
  FPlayBufferPos := PlayPosition;
1527
end;
1528
 
1529
function TAudioStream.GetWriteSize: Integer;
1530
var
1531
  PlayPosition: DWORD;
1532
  i: Integer;
1533
begin
1534
  PlayPosition := FBuffer.Position;
1535
 
1536
  if FBufferPos <= PlayPosition then
1537
  begin
1538
    Result := PlayPosition - FBufferPos
1539
  end else
1540
  begin
1541
    Result := PlayPosition + (FBufferSize - FBufferPos);
1542
  end;
1543
 
1544
  i := WaveStream.FilledSize;
4 daniel-mar 1545
  if i >= 0 then Result := Min(Result, i);
1 daniel-mar 1546
end;
1547
 
1548
procedure TAudioStream.Play;
1549
begin
1550
  if not FPlaying then
1551
  begin
4 daniel-mar 1552
    if WaveStream = nil then
1 daniel-mar 1553
      raise EAudioStreamError.Create(SWaveStreamNotSet);
1554
 
4 daniel-mar 1555
    if Size = 0 then Exit;
1 daniel-mar 1556
 
1557
    FPlaying := True;
1558
    try
1559
      SetPosition(FPosition);
1560
      if FAutoUpdate then
1561
        FNotifyThread := TAudioStreamNotify.Create(Self);
1562
    except
1563
      Stop;
1564
      raise;
1565
    end;
1566
  end;
1567
end;
1568
 
1569
procedure TAudioStream.RecreateBuf;
1570
var
1571
  APlaying: Boolean;
1572
  APosition: Integer;
1573
  AFrequency: Integer;
1574
  APan: Integer;
1575
  AVolume: Integer;
1576
begin
1577
  APlaying := Playing;
4 daniel-mar 1578
 
1 daniel-mar 1579
  APosition := Position;
1580
  AFrequency := Frequency;
1581
  APan := Pan;
1582
  AVolume := Volume;
4 daniel-mar 1583
 
1 daniel-mar 1584
  SetWaveStream(WaveStream);
1585
 
1586
  Position := APosition;
1587
  Frequency := AFrequency;
1588
  Pan := APan;
1589
  Volume := AVolume;
4 daniel-mar 1590
 
1 daniel-mar 1591
  if APlaying then Play;
1592
end;
1593
 
1594
procedure TAudioStream.SetAutoUpdate(Value: Boolean);
1595
begin
4 daniel-mar 1596
  if FAutoUpdate <> Value then
1 daniel-mar 1597
  begin
1598
    FAutoUpdate := Value;
1599
    if FPlaying then
1600
    begin
4 daniel-mar 1601
      if FNotifyThread <> nil then
1 daniel-mar 1602
      begin
1603
        (FNotifyThread as TAudioStreamNotify).FStopOnTerminate := False;
1604
        FNotifyThread.Free;
1605
      end;
1606
 
1607
      if FAutoUpdate then
1608
        FNotifyThread := TAudioStreamNotify.Create(Self);
1609
    end;
1610
  end;
1611
end;
1612
 
1613
procedure TAudioStream.SetBufferLength(Value: Integer);
1614
begin
4 daniel-mar 1615
  if Value < 10 then Value := 10;
1616
  if FBufferLength <> Value then
1 daniel-mar 1617
  begin
1618
    FBufferLength := Value;
4 daniel-mar 1619
    if WaveStream <> nil then RecreateBuf;
1 daniel-mar 1620
  end;
1621
end;
1622
 
1623
procedure TAudioStream.SetFrequency(Value: Integer);
1624
begin
1625
  FBuffer.Frequency := Value;
1626
end;
1627
 
1628
procedure TAudioStream.SetLooped(Value: Boolean);
1629
begin
4 daniel-mar 1630
  if FLooped <> Value then
1 daniel-mar 1631
  begin
1632
    FLooped := Value;
1633
    Position := Position;
1634
  end;
1635
end;
1636
 
1637
procedure TAudioStream.SetPan(Value: Integer);
1638
begin
1639
  FBuffer.Pan := Value;
1640
end;
1641
 
1642
procedure TAudioStream.SetPlayedSize(Value: Integer);
1643
begin
1644
  if Playing then UpdatePlayedSize;
1645
  FPlayedSize := Value;
1646
end;
1647
 
1648
procedure TAudioStream.SetPosition(Value: Integer);
1649
begin
4 daniel-mar 1650
  if WaveStream = nil then
1 daniel-mar 1651
    raise EAudioStreamError.Create(SWaveStreamNotSet);
1652
 
4 daniel-mar 1653
  Value := Max(Min(Value, Size - 1), 0);
1 daniel-mar 1654
  Value := Value div Format^.nBlockAlign * Format^.nBlockAlign;
1655
 
1656
  FPosition := Value;
1657
 
1658
  if Playing then
1659
  begin
1660
    try
1661
      FBuffer.Stop;
1662
 
1663
      FBufferPos := 0;
1664
      FPlayBufferPos := 0;
1665
      FWritePosition := Value;
1666
 
1667
      WriteWave(FBufferSize);
1668
 
1669
      FBuffer.Position := 0;
1670
      FBuffer.Play(True);
1671
    except
1672
      Stop;
1673
      raise;
1674
    end;
1675
  end;
1676
end;
1677
 
1678
procedure TAudioStream.SetVolume(Value: Integer);
1679
begin
1680
  FBuffer.Volume := Value;
1681
end;
1682
 
1683
procedure TAudioStream.SetWaveStream(Value: TCustomWaveStream);
1684
var
1685
  BufferDesc: TDSBufferDesc;
1686
begin
1687
  Stop;
1688
 
1689
  FWaveStream := nil;
1690
  FBufferPos := 0;
1691
  FPosition := 0;
1692
  FWritePosition := 0;
1693
 
4 daniel-mar 1694
  if (Value <> nil) and (FBufferLength > 0) then
1 daniel-mar 1695
  begin
1696
    FBufferSize := FBufferLength * Integer(Value.Format^.nAvgBytesPerSec) div 1000;
1697
 
1698
    FillChar(BufferDesc, SizeOf(BufferDesc), 0);
1699
    with BufferDesc do
1700
    begin
1701
      dwSize := SizeOf(TDSBufferDesc);
1702
      dwFlags := DSBCAPS_CTRLDEFAULT or DSBCAPS_GETCURRENTPOSITION2;
1703
      if FDSound.FStickyFocus then
1704
        dwFlags := dwFlags or DSBCAPS_STICKYFOCUS
1705
      else if FDSound.FGlobalFocus then
1706
        dwFlags := dwFlags or DSBCAPS_GLOBALFOCUS;
1707
      dwBufferBytes := FBufferSize;
1708
      lpwfxFormat := Value.Format;
1709
    end;
1710
 
1711
    if not FBuffer.CreateBuffer(BufferDesc) then
1712
      raise EDirectSoundBufferError.CreateFmt(SCannotMade, [SDirectSoundBuffer]);
1713
  end else
1714
  begin
1715
    FBuffer.IDSBuffer := nil;
1716
    FBufferSize := 0;
1717
  end;
1718
 
1719
  FWaveStream := Value;
1720
end;
1721
 
1722
procedure TAudioStream.Stop;
1723
begin
1724
  if FPlaying then
1725
  begin
1726
    FPlaying := False;
1727
    FBuffer.Stop;
1728
    FNotifyThread.Free;
1729
  end;
1730
end;
1731
 
1732
procedure TAudioStream.Update;
1733
begin
1734
  Update2(False);
1735
end;
1736
 
1737
procedure TAudioStream.Update2(InThread: Boolean);
1738
var
1739
  WriteSize: Integer;
1740
begin
1741
  if not FPlaying then Exit;
1742
 
1743
  try
1744
    UpdatePlayedSize;
1745
 
4 daniel-mar 1746
    if Size < 0 then
1 daniel-mar 1747
    begin
1748
      WriteSize := GetWriteSize;
4 daniel-mar 1749
      if WriteSize > 0 then
1 daniel-mar 1750
      begin
1751
        WriteSize := WriteWave(WriteSize);
1752
        FPosition := FPosition + WriteSize;
1753
      end;
1754
    end else
1755
    begin
1756
      if FLooped then
1757
      begin
1758
        WriteSize := GetWriteSize;
4 daniel-mar 1759
        if WriteSize > 0 then
1 daniel-mar 1760
        begin
1761
          WriteWave(WriteSize);
1762
          FPosition := (FPosition + WriteSize) mod Size;
1763
        end;
1764
      end else
1765
      begin
4 daniel-mar 1766
        if FPosition < Size then
1 daniel-mar 1767
        begin
1768
          WriteSize := GetWriteSize;
4 daniel-mar 1769
          if WriteSize > 0 then
1 daniel-mar 1770
          begin
1771
            WriteWave(WriteSize);
1772
            FPosition := FPosition + WriteSize;
4 daniel-mar 1773
            if FPosition > Size then FPosition := Size;
1 daniel-mar 1774
          end;
1775
        end else
1776
        begin
1777
          if InThread then
1778
            SetEvent(FNotifyEvent)
1779
          else
1780
            Stop;
1781
        end;
1782
      end;
1783
    end;
1784
  except
1785
    if InThread then
1786
      SetEvent(FNotifyEvent)
1787
    else
1788
      Stop;
1789
    raise;
1790
  end;
1791
end;
1792
 
1793
function TAudioStream.WriteWave(WriteSize: Integer): Integer;
1794
 
1795
  procedure WriteData(Size: Integer);
1796
  var
1797
    Data1, Data2: Pointer;
1798
    Data1Size, Data2Size: Longint;
1799
  begin
1800
    if FBuffer.Lock(FBufferPos, Size, Data1, Data1Size, Data2, Data2Size) then
1801
    begin
1802
      try
1803
        FWaveStream.Position := FWritePosition;
1804
        FWaveStream.ReadBuffer(Data1^, Data1Size);
1805
        FWritePosition := FWritePosition + Data1Size;
1806
 
4 daniel-mar 1807
        if Data2 <> nil then
1 daniel-mar 1808
        begin
1809
          FWaveStream.ReadBuffer(Data2^, Data2Size);
1810
          FWritePosition := FWritePosition + Data2Size;
1811
        end;
1812
 
1813
        FBufferPos := (FBufferPos + DWORD(Data1Size) + DWORD(Data2Size)) mod FBufferSize;
1814
      finally
1815
        FBuffer.UnLock;
1816
      end;
1817
    end;
1818
  end;
1819
 
1820
  procedure WriteData2(Size: Integer);
1821
  var
1822
    Data1, Data2: Pointer;
1823
    Data1Size, Data2Size, s1, s2: Longint;
1824
  begin
1825
    if FBuffer.Lock(FBufferPos, Size, Data1, Data1Size, Data2, Data2Size) then
1826
    begin
1827
      try
1828
        FWaveStream.Position := FWritePosition;
1829
        s1 := FWaveStream.Read(Data1^, Data1Size);
1830
        FWritePosition := FWritePosition + s1;
1831
        FBufferPos := (FBufferPos + DWORD(s1)) mod FBufferSize;
1832
        Inc(Result, s1);
1833
 
4 daniel-mar 1834
        if (Data2 <> nil) and (s1 = Data1Size) then
1 daniel-mar 1835
        begin
1836
          s2 := FWaveStream.Read(Data2^, Data2Size);
1837
          FWritePosition := FWritePosition + s2;
1838
          FBufferPos := (FBufferPos + DWORD(s2)) mod FBufferSize;
1839
          Inc(Result, s2);
1840
        end;
1841
      finally
1842
        FBuffer.UnLock;
1843
      end;
1844
    end;
1845
  end;
1846
 
1847
  procedure WriteSilence(Size: Integer);
1848
  var
1849
    C: Byte;
1850
    Data1, Data2: Pointer;
1851
    Data1Size, Data2Size: Longint;
1852
  begin
4 daniel-mar 1853
    if Format^.wBitsPerSample = 8 then C := $80 else C := 0;
1 daniel-mar 1854
 
1855
    if FBuffer.Lock(FBufferPos, Size, Data1, Data1Size, Data2, Data2Size) then
1856
    begin
1857
      try
1858
        FillChar(Data1^, Data1Size, C);
1859
 
4 daniel-mar 1860
        if Data2 <> nil then
1 daniel-mar 1861
          FillChar(Data2^, Data2Size, C);
1862
      finally
1863
        FBuffer.UnLock;
1864
      end;
1865
      FBufferPos := (FBufferPos + DWORD(Data1Size) + DWORD(Data2Size)) mod FBufferSize;
1866
      FWritePosition := FWritePosition + Data1Size + Data2Size;
1867
    end;
1868
  end;
1869
 
1870
var
1871
  DataSize: Integer;
1872
begin
4 daniel-mar 1873
  if Size >= 0 then
1 daniel-mar 1874
  begin
1875
    Result := WriteSize;
1876
    if FLooped then
1877
    begin
4 daniel-mar 1878
      while WriteSize > 0 do
1 daniel-mar 1879
      begin
4 daniel-mar 1880
        DataSize := Min(Size - FWritePosition, WriteSize);
1 daniel-mar 1881
 
1882
        WriteData(DataSize);
1883
        FWritePosition := FWritePosition mod Size;
1884
 
1885
        Dec(WriteSize, DataSize);
1886
      end;
1887
    end else
1888
    begin
4 daniel-mar 1889
      DataSize := Size - FWritePosition;
1 daniel-mar 1890
 
4 daniel-mar 1891
      if DataSize <= 0 then
1 daniel-mar 1892
      begin
1893
        WriteSilence(WriteSize);
1894
      end else
4 daniel-mar 1895
        if DataSize >= WriteSize then
1896
        begin
1897
          WriteData(WriteSize);
1898
        end else
1899
        begin
1900
          WriteData(DataSize);
1901
          WriteSilence(WriteSize - DataSize);
1902
        end;
1 daniel-mar 1903
    end;
1904
  end else
1905
  begin
1906
    Result := 0;
1907
    WriteData2(WriteSize);
1908
  end;
1909
end;
1910
 
1911
{  TAudioFileStream  }
1912
 
1913
destructor TAudioFileStream.Destroy;
1914
begin
1915
  inherited Destroy;
1916
  FWaveFileStream.Free;
1917
end;
1918
 
1919
procedure TAudioFileStream.SetFileName(const Value: string);
1920
begin
4 daniel-mar 1921
  if FFileName = Value then Exit;
1 daniel-mar 1922
 
1923
  FFileName := Value;
1924
 
4 daniel-mar 1925
  if FWaveFileStream <> nil then
1 daniel-mar 1926
  begin
1927
    WaveStream := nil;
1928
    FWaveFileStream.Free;
1929
    FWaveFileStream := nil;
1930
  end;
1931
 
4 daniel-mar 1932
  if Value <> '' then
1 daniel-mar 1933
  begin
1934
    try
1935
      FWaveFileStream := TWaveFileStream.Create(Value, fmOpenRead or fmShareDenyWrite);
1936
      FWaveFileStream.Open(False);
1937
      WaveStream := FWaveFileStream;
1938
    except
1939
      WaveStream := nil;
1940
      FFileName := '';
1941
      raise;
1942
    end;
1943
  end;
1944
end;
1945
 
1946
{  TSoundCaptureFormats  }
1947
 
1948
constructor TSoundCaptureFormats.Create;
1949
begin
1950
  inherited Create(TSoundCaptureFormat);
1951
end;
1952
 
1953
function TSoundCaptureFormats.GetItem(Index: Integer): TSoundCaptureFormat;
1954
begin
1955
  Result := TSoundCaptureFormat(inherited Items[Index]);
1956
end;
1957
 
1958
function TSoundCaptureFormats.IndexOf(ASamplesPerSec, ABitsPerSample, AChannels: Integer): Integer;
1959
var
1960
  i: Integer;
1961
begin
1962
  Result := -1;
4 daniel-mar 1963
  for i := 0 to Count - 1 do
1 daniel-mar 1964
    with Items[i] do
4 daniel-mar 1965
      if (FSamplesPerSec = ASamplesPerSec) and (FBitsPerSample = ABitsPerSample) and (FChannels = AChannels) then
1 daniel-mar 1966
      begin
1967
        Result := i;
1968
        Break;
1969
      end;
1970
end;
1971
 
1972
{  TSoundCaptureStream  }
1973
 
1974
type
1975
  TSoundCaptureStreamNotify = class(TThread)
1976
  private
1977
    FCapture: TSoundCaptureStream;
1978
    FSleepTime: Integer;
1979
    constructor Create(Capture: TSoundCaptureStream);
1980
    destructor Destroy; override;
1981
    procedure Execute; override;
1982
    procedure Update;
1983
  end;
1984
 
1985
constructor TSoundCaptureStreamNotify.Create(Capture: TSoundCaptureStream);
1986
begin
1987
  FCapture := Capture;
1988
 
1989
  FCapture.FNotifyEvent := CreateEvent(nil, False, False, nil);
1990
  FSleepTime := Min(FCapture.FBufferLength div 4, 1000 div 20);
1991
 
1992
  FreeOnTerminate := True;
1993
  inherited Create(True);
1994
end;
1995
 
1996
destructor TSoundCaptureStreamNotify.Destroy;
1997
begin
1998
  FreeOnTerminate := False;
1999
  SetEvent(FCapture.FNotifyEvent);
2000
 
2001
  inherited Destroy;
2002
 
2003
  CloseHandle(FCapture.FNotifyEvent);
2004
  FCapture.FNotifyThread := nil;
2005
 
2006
  if Assigned(FCapture.FOnFilledBuffer) then FCapture.Stop;
2007
end;
2008
 
2009
procedure TSoundCaptureStreamNotify.Execute;
2010
begin
4 daniel-mar 2011
  while WaitForSingleObject(FCapture.FNotifyEvent, FSleepTime) = WAIT_TIMEOUT do
1 daniel-mar 2012
  begin
2013
    Synchronize(Update);
2014
  end;
2015
end;
2016
 
2017
procedure TSoundCaptureStreamNotify.Update;
2018
begin
4 daniel-mar 2019
  if FCapture.FilledSize > 0 then
1 daniel-mar 2020
  begin
2021
    try
2022
      FCapture.DoFilledBuffer;
2023
    except
2024
      on E: Exception do
2025
      begin
2026
        Application.HandleException(E);
2027
        SetEvent(FCapture.FNotifyEvent);
2028
      end;
2029
    end;
2030
  end;
2031
end;
2032
 
2033
constructor TSoundCaptureStream.Create(GUID: PGUID);
2034
const
2035
  SamplesPerSecList: array[0..6] of Integer = (8000, 11025, 22050, 33075, 44100, 48000, 96000);
2036
  BitsPerSampleList: array[0..3] of Integer = (8, 16, 24, 32);
2037
  ChannelsList: array[0..1] of Integer = (1, 2);
2038
var
2039
  ASamplesPerSec, ABitsPerSample, AChannels: Integer;
2040
  dscbd: TDSCBufferDesc;
2041
  TempBuffer: IDirectSoundCaptureBuffer;
2042
  Format: TWaveFormatEx;
2043
begin
2044
  inherited Create;
2045
  FBufferLength := 1000;
2046
  FSupportedFormats := TSoundCaptureFormats.Create;
2047
 
4 daniel-mar 2048
  if DXDirectSoundCaptureCreate(GUID, FCapture, nil) <> DS_OK then
1 daniel-mar 2049
    raise ESoundCaptureStreamError.CreateFmt(SCannotInitialized, [SDirectSoundCapture]);
2050
 
2051
  {  The supported format list is acquired.  }
4 daniel-mar 2052
  for ASamplesPerSec := Low(SamplesPerSecList) to High(SamplesPerSecList) do
2053
    for ABitsPerSample := Low(BitsPerSampleList) to High(BitsPerSampleList) do
2054
      for AChannels := Low(ChannelsList) to High(ChannelsList) do
1 daniel-mar 2055
      begin
2056
        {  Test  }
2057
        MakePCMWaveFormatEx(Format, SamplesPerSecList[ASamplesPerSec], BitsPerSampleList[ABitsPerSample], ChannelsList[AChannels]);
2058
 
2059
        FillChar(dscbd, SizeOf(dscbd), 0);
2060
        dscbd.dwSize := SizeOf(dscbd);
2061
        dscbd.dwBufferBytes := Format.nAvgBytesPerSec;
2062
        dscbd.lpwfxFormat := @Format;
2063
 
2064
        {  If the buffer can be made,  the format of present can be used.  }
4 daniel-mar 2065
        if FCapture.CreateCaptureBuffer(dscbd, TempBuffer, nil) = DS_OK then
1 daniel-mar 2066
        begin
2067
          TempBuffer := nil;
2068
          with TSoundCaptureFormat.Create(FSupportedFormats) do
2069
          begin
2070
            FSamplesPerSec := Format.nSamplesPerSec;
2071
            FBitsPerSample := Format.wBitsPerSample;
2072
            FChannels := Format.nChannels;
2073
          end;
2074
        end;
2075
      end;
2076
end;
2077
 
2078
destructor TSoundCaptureStream.Destroy;
2079
begin
2080
  Stop;
2081
  FSupportedFormats.Free;
2082
  inherited Destroy;
2083
end;
2084
 
2085
procedure TSoundCaptureStream.DoFilledBuffer;
2086
begin
2087
  if Assigned(FOnFilledBuffer) then FOnFilledBuffer(Self);
2088
end;
2089
 
2090
class function TSoundCaptureStream.Drivers: TDirectXDrivers;
2091
begin
2092
  Result := EnumDirectSoundCaptureDrivers;
2093
end;
2094
 
2095
function TSoundCaptureStream.GetFilledSize: Integer;
2096
begin
2097
  Result := GetReadSize;
2098
end;
2099
 
2100
function TSoundCaptureStream.GetReadSize: Integer;
2101
var
2102
  CapturePosition, ReadPosition: DWORD;
2103
begin
4 daniel-mar 2104
  if FBuffer.GetCurrentPosition(@DWORD(CapturePosition), @DWORD(ReadPosition)) = DS_OK then
1 daniel-mar 2105
  begin
4 daniel-mar 2106
    if FBufferPos <= ReadPosition then
1 daniel-mar 2107
      Result := ReadPosition - FBufferPos
2108
    else
2109
      Result := FBufferSize - FBufferPos + ReadPosition;
2110
  end else
2111
    Result := 0;
2112
end;
2113
 
2114
function TSoundCaptureStream.ReadWave(var Buffer; Count: Integer): Integer;
2115
var
2116
  Size: Integer;
2117
  Data1, Data2: Pointer;
2118
  Data1Size, Data2Size: DWORD;
2119
  C: Byte;
2120
begin
2121
  if not FCapturing then
2122
    Start;
4 daniel-mar 2123
  Data1 := nil;
2124
  Data2 := nil;
1 daniel-mar 2125
  Result := 0;
4 daniel-mar 2126
  while Result < Count do
1 daniel-mar 2127
  begin
4 daniel-mar 2128
    Size := Min(Count - Result, GetReadSize);
2129
    if Size > 0 then
1 daniel-mar 2130
    begin
4 daniel-mar 2131
      if FBuffer.Lock(FBufferPos, Size, Data1, {$IFNDEF DX7}@{$ENDIF}Data1Size,
2132
        Data2, {$IFNDEF DX7}@{$ENDIF}Data2Size, 0) = DS_OK then
1 daniel-mar 2133
      begin
4 daniel-mar 2134
        Move(Data1^, Pointer(Integer(@Buffer) + Result)^, Data1Size);
1 daniel-mar 2135
        Result := Result + Integer(Data1Size);
2136
 
4 daniel-mar 2137
        if Data2 <> nil then
1 daniel-mar 2138
        begin
4 daniel-mar 2139
          Move(Data2^, Pointer(Integer(@Buffer) + Result)^, Data2Size);
1 daniel-mar 2140
          Result := Result + Integer(Data1Size);
2141
        end;
2142
 
2143
        FBuffer.UnLock(Data1, Data1Size, Data2, Data2Size);
2144
        FBufferPos := (FBufferPos + Data1Size + Data2Size) mod FBufferSize;
2145
      end else
2146
        Break;
2147
    end;
4 daniel-mar 2148
    if Result < Count then Sleep(50);
1 daniel-mar 2149
  end;
2150
 
2151
  case Format^.wBitsPerSample of
4 daniel-mar 2152
    8: C := $80;
1 daniel-mar 2153
    16: C := $00;
2154
  else
2155
    C := $00;
2156
  end;
2157
 
4 daniel-mar 2158
  FillChar(Pointer(Integer(@Buffer) + Result)^, Count - Result, C);
1 daniel-mar 2159
  Result := Count;
2160
end;
2161
 
2162
procedure TSoundCaptureStream.SetBufferLength(Value: Integer);
2163
begin
2164
  FBufferLength := Max(Value, 0);
2165
end;
2166
 
2167
procedure TSoundCaptureStream.SetOnFilledBuffer(Value: TNotifyEvent);
2168
begin
2169
  if CompareMem(@TMethod(FOnFilledBuffer), @TMethod(Value), SizeOf(TMethod)) then Exit;
2170
 
2171
  if FCapturing then
2172
  begin
2173
    if Assigned(FOnFilledBuffer) then
2174
      FNotifyThread.Free;
2175
 
2176
    FOnFilledBuffer := Value;
2177
 
2178
    if Assigned(FOnFilledBuffer) then
2179
    begin
2180
      FNotifyThread := TSoundCaptureStreamNotify.Create(Self);
2181
      FNotifyThread.Resume;
2182
    end;
2183
  end else
2184
    FOnFilledBuffer := Value;
2185
end;
2186
 
2187
procedure TSoundCaptureStream.Start;
2188
var
2189
  dscbd: TDSCBufferDesc;
2190
begin
2191
  Stop;
2192
  try
2193
    FCapturing := True;
2194
 
2195
    FormatSize := SizeOf(TWaveFormatEx);
2196
    with FSupportedFormats[CaptureFormat] do
2197
      MakePCMWaveFormatEx(Format^, SamplesPerSec, BitsPerSample, Channels);
2198
 
2199
    FBufferSize := Max(MulDiv(Format^.nAvgBytesPerSec, FBufferLength, 1000), 8000);
2200
 
2201
    FillChar(dscbd, SizeOf(dscbd), 0);
2202
    dscbd.dwSize := SizeOf(dscbd);
2203
    dscbd.dwBufferBytes := FBufferSize;
2204
    dscbd.lpwfxFormat := Format;
2205
 
4 daniel-mar 2206
    if FCapture.CreateCaptureBuffer(dscbd, FBuffer, nil) <> DS_OK then
1 daniel-mar 2207
      raise ESoundCaptureStreamError.CreateFmt(SCannotMade, [SDirectSoundCaptureBuffer]);
2208
 
2209
    FBufferPos := 0;
2210
 
2211
    FBuffer.Start(DSCBSTART_LOOPING);
2212
 
2213
    if Assigned(FOnFilledBuffer) then
2214
    begin
2215
      FNotifyThread := TSoundCaptureStreamNotify.Create(Self);
2216
      FNotifyThread.Resume;
2217
    end;
2218
  except
2219
    Stop;
2220
    raise;
2221
  end;
2222
end;
2223
 
2224
procedure TSoundCaptureStream.Stop;
2225
begin
2226
  if FCapturing then
2227
  begin
2228
    FNotifyThread.Free;
2229
    FCapturing := False;
4 daniel-mar 2230
    if FBuffer <> nil then
1 daniel-mar 2231
      FBuffer.Stop;
2232
    FBuffer := nil;
2233
  end;
2234
end;
2235
 
2236
{  TSoundEngine  }
2237
 
2238
constructor TSoundEngine.Create(ADSound: TDirectSound);
2239
begin
2240
  inherited Create;
2241
  FDSound := ADSound;
2242
  FEnabled := True;
2243
 
2244
  FEffectList := TList.Create;
2245
  FTimer := TTimer.Create(nil);
2246
  FTimer.Interval := 500;
2247
  FTimer.OnTimer := TimerEvent;
2248
end;
2249
 
2250
destructor TSoundEngine.Destroy;
2251
begin
2252
  Clear;
2253
  FTimer.Free;
2254
  FEffectList.Free;
2255
  inherited Destroy;
2256
end;
2257
 
2258
procedure TSoundEngine.Clear;
2259
var
2260
  i: Integer;
2261
begin
4 daniel-mar 2262
  for i := EffectCount - 1 downto 0 do
1 daniel-mar 2263
    Effects[i].Free;
2264
  FEffectList.Clear;
2265
end;
2266
 
2267
procedure TSoundEngine.EffectFile(const Filename: string; Loop, Wait: Boolean);
2268
var
4 daniel-mar 2269
  Stream: TFileStream;
1 daniel-mar 2270
begin
4 daniel-mar 2271
  Stream := TFileStream.Create(Filename, fmOpenRead);
1 daniel-mar 2272
  try
2273
    EffectStream(Stream, Loop, Wait);
2274
  finally
2275
    Stream.Free;
2276
  end;
2277
end;
2278
 
2279
procedure TSoundEngine.EffectStream(Stream: TStream; Loop, Wait: Boolean);
2280
var
2281
  Wave: TWave;
2282
begin
2283
  Wave := TWave.Create;
2284
  try
2285
    Wave.LoadfromStream(Stream);
2286
    EffectWave(Wave, Loop, Wait);
2287
  finally
2288
    Wave.Free;
2289
  end;
2290
end;
2291
 
2292
procedure TSoundEngine.EffectWave(Wave: TWave; Loop, Wait: Boolean);
2293
var
2294
  Buffer: TDirectSoundBuffer;
2295
begin
2296
  if not FEnabled then Exit;
2297
 
2298
  if Wait then
2299
  begin
2300
    Buffer := TDirectSoundBuffer.Create(FDSound);
2301
    try
2302
      Buffer.LoadFromWave(Wave);
2303
      Buffer.Play(False);
2304
      while Buffer.Playing do
2305
        Sleep(1);
2306
    finally
2307
      Buffer.Free;
2308
    end;
2309
  end else
2310
  begin
2311
    Buffer := TDirectSoundBuffer.Create(FDSound);
2312
    try
2313
      Buffer.LoadFromWave(Wave);
2314
      Buffer.Play(Loop);
2315
    except
2316
      Buffer.Free;
2317
      raise;
2318
    end;
2319
    FEffectList.Add(Buffer);
2320
  end;
2321
end;
2322
 
2323
function TSoundEngine.GetEffect(Index: Integer): TDirectSoundBuffer;
2324
begin
2325
  Result := TDirectSoundBuffer(FEffectList[Index]);
2326
end;
2327
 
2328
function TSoundEngine.GetEffectCount: Integer;
2329
begin
2330
  Result := FEffectList.Count;
2331
end;
2332
 
2333
procedure TSoundEngine.SetEnabled(Value: Boolean);
2334
var
2335
  i: Integer;
2336
begin
4 daniel-mar 2337
  for i := EffectCount - 1 downto 0 do
1 daniel-mar 2338
    Effects[i].Free;
2339
  FEffectList.Clear;
2340
 
2341
  FEnabled := Value;
2342
  FTimer.Enabled := Value;
2343
end;
2344
 
2345
procedure TSoundEngine.TimerEvent(Sender: TObject);
2346
var
2347
  i: Integer;
2348
begin
4 daniel-mar 2349
  for i := EffectCount - 1 downto 0 do
1 daniel-mar 2350
    if not TDirectSoundBuffer(FEffectList[i]).Playing then
2351
    begin
2352
      TDirectSoundBuffer(FEffectList[i]).Free;
2353
      FEffectList.Delete(i);
2354
    end;
2355
end;
2356
 
2357
{  TCustomDXSound  }
2358
 
2359
type
2360
  TDXSoundDirectSound = class(TDirectSound)
2361
  private
2362
    FDXSound: TCustomDXSound;
2363
  protected
2364
    procedure DoRestoreBuffer; override;
2365
  end;
2366
 
2367
procedure TDXSoundDirectSound.DoRestoreBuffer;
2368
begin
2369
  inherited DoRestoreBuffer;
2370
  FDXSound.Restore;
2371
end;
2372
 
2373
constructor TCustomDXSound.Create(AOwner: TComponent);
2374
begin
2375
  FNotifyEventList := TList.Create;
2376
  inherited Create(AOwner);
2377
  FAutoInitialize := True;
2378
  Options := [];
2379
end;
2380
 
2381
destructor TCustomDXSound.Destroy;
2382
begin
2383
  Finalize;
2384
  NotifyEventList(dsntDestroying);
2385
  FNotifyEventList.Free;
2386
  inherited Destroy;
2387
end;
2388
 
2389
type
2390
  PDXSoundNotifyEvent = ^TDXSoundNotifyEvent;
2391
 
2392
procedure TCustomDXSound.RegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);
2393
var
2394
  Event: PDXSoundNotifyEvent;
2395
begin
2396
  UnRegisterNotifyEvent(NotifyEvent);
2397
 
2398
  New(Event);
2399
  Event^ := NotifyEvent;
2400
  FNotifyEventList.Add(Event);
2401
 
2402
  if Initialized then
2403
  begin
2404
    NotifyEvent(Self, dsntInitialize);
2405
    NotifyEvent(Self, dsntRestore);
2406
  end;
2407
end;
2408
 
2409
procedure TCustomDXSound.UnRegisterNotifyEvent(NotifyEvent: TDXSoundNotifyEvent);
2410
var
2411
  Event: PDXSoundNotifyEvent;
2412
  i: Integer;
2413
begin
4 daniel-mar 2414
  for i := 0 to FNotifyEventList.Count - 1 do
1 daniel-mar 2415
  begin
2416
    Event := FNotifyEventList[i];
2417
    if (TMethod(Event^).Code = TMethod(NotifyEvent).Code) and
2418
      (TMethod(Event^).Data = TMethod(NotifyEvent).Data) then
2419
    begin
2420
      Dispose(Event);
2421
      FNotifyEventList.Delete(i);
2422
 
2423
      if Initialized then
2424
        NotifyEvent(Self, dsntFinalize);
2425
 
2426
      Break;
2427
    end;
2428
  end;
2429
end;
2430
 
2431
procedure TCustomDXSound.NotifyEventList(NotifyType: TDXSoundNotifyType);
2432
var
2433
  i: Integer;
2434
begin
4 daniel-mar 2435
  for i := FNotifyEventList.Count - 1 downto 0 do
1 daniel-mar 2436
    PDXSoundNotifyEvent(FNotifyEventList[i])^(Self, NotifyType);
2437
end;
2438
 
2439
procedure TCustomDXSound.FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
2440
begin
2441
  case Message.Msg of
2442
    WM_CREATE:
4 daniel-mar 2443
      begin
2444
        DefWindowProc(Message);
2445
        SetForm(FForm);
2446
        Exit;
2447
      end;
1 daniel-mar 2448
  end;
2449
  DefWindowProc(Message);
2450
end;
2451
 
2452
class function TCustomDXSound.Drivers: TDirectXDrivers;
2453
begin
2454
  Result := EnumDirectSoundDrivers;
2455
end;
2456
 
2457
procedure TCustomDXSound.DoFinalize;
2458
begin
2459
  if Assigned(FOnFinalize) then FOnFinalize(Self);
2460
end;
2461
 
2462
procedure TCustomDXSound.DoInitialize;
2463
begin
2464
  if Assigned(FOnInitialize) then FOnInitialize(Self);
2465
end;
2466
 
2467
procedure TCustomDXSound.DoInitializing;
2468
begin
2469
  if Assigned(FOnInitializing) then FOnInitializing(Self);
2470
end;
2471
 
2472
procedure TCustomDXSound.DoRestore;
2473
begin
2474
  if Assigned(FOnRestore) then FOnRestore(Self);
2475
end;
2476
 
2477
procedure TCustomDXSound.Finalize;
2478
begin
2479
  if FInternalInitialized then
2480
  begin
2481
    try
2482
      FSubClass.Free; FSubClass := nil;
2483
 
2484
      try
2485
        if FCalledDoInitialize then
2486
        begin
2487
          FCalledDoInitialize := False;
2488
          DoFinalize;
2489
        end;
2490
      finally
2491
        NotifyEventList(dsntFinalize);
2492
      end;
2493
    finally
2494
      FInitialized := False;
2495
      FInternalInitialized := False;
2496
 
2497
      SetOptions(FOptions);
2498
 
2499
      FPrimary.Free; FPrimary := nil;
4 daniel-mar 2500
      FDSound.Free; FDSound := nil;
1 daniel-mar 2501
    end;
2502
  end;
2503
end;
2504
 
2505
procedure TCustomDXSound.Initialize;
2506
const
2507
  PrimaryDesc: TDSBufferDesc = (
4 daniel-mar 2508
    dwSize: SizeOf(PrimaryDesc);
2509
    dwFlags: DSBCAPS_PRIMARYBUFFER);
1 daniel-mar 2510
var
2511
  Component: TComponent;
2512
begin
2513
  Finalize;
2514
 
2515
  Component := Owner;
4 daniel-mar 2516
  while (Component <> nil) and (not (Component is TCustomForm)) do
1 daniel-mar 2517
    Component := Component.Owner;
4 daniel-mar 2518
  if Component = nil then
1 daniel-mar 2519
    raise EDXSoundError.Create(SNoForm);
2520
 
2521
  NotifyEventList(dsntInitializing);
2522
  DoInitializing;
2523
 
2524
  FInternalInitialized := True;
2525
  try
2526
    {  DirectSound initialization.  }
2527
    FDSound := TDXSoundDirectSound.Create(Driver);
2528
    TDXSoundDirectSound(FDSound).FDXSound := Self;
2529
 
2530
    FDSound.FGlobalFocus := soGlobalFocus in FNowOptions;
2531
 
2532
    {  Primary buffer made.  }
2533
    FPrimary := TDirectSoundBuffer.Create(FDSound);
2534
    if not FPrimary.CreateBuffer(PrimaryDesc) then
2535
      raise EDXSoundError.CreateFmt(SCannotMade, [SDirectSoundPrimaryBuffer]);
2536
 
2537
    FInitialized := True;
2538
 
2539
    SetForm(TCustomForm(Component));
2540
  except
2541
    Finalize;
2542
    raise;
2543
  end;
2544
 
2545
  NotifyEventList(dsntInitialize);
2546
 
2547
  FCalledDoInitialize := True; DoInitialize;
2548
 
2549
  Restore;
2550
end;
2551
 
2552
procedure TCustomDXSound.Loaded;
2553
begin
2554
  inherited Loaded;
2555
 
2556
  if FAutoInitialize and (not (csDesigning in ComponentState)) then
2557
  begin
2558
    try
2559
      Initialize;
2560
    except
2561
      on E: EDirectSoundError do ;
4 daniel-mar 2562
    else raise;
1 daniel-mar 2563
    end;
2564
  end;
2565
end;
2566
 
2567
procedure TCustomDXSound.Restore;
2568
begin
2569
  if FInitialized then
2570
  begin
2571
    NotifyEventList(dsntRestore);
2572
    DoRestore;
2573
  end;
2574
end;
2575
 
2576
procedure TCustomDXSound.SetDriver(Value: PGUID);
2577
begin
2578
  if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
2579
  begin
2580
    FDriverGUID := Value^;
2581
    FDriver := @FDriverGUID;
2582
  end else
2583
    FDriver := Value;
2584
end;
2585
 
2586
procedure TCustomDXSound.SetForm(Value: TCustomForm);
2587
var
2588
  Level: Integer;
2589
begin
2590
  FForm := Value;
2591
 
2592
  FSubClass.Free;
2593
  FSubClass := TControlSubClass.Create(FForm, FormWndProc);
2594
 
2595
  if FInitialized then
2596
  begin
2597
    if soExclusive in FNowOptions then
2598
      Level := DSSCL_EXCLUSIVE
2599
    else
2600
      Level := DSSCL_NORMAL;
2601
 
2602
    FDSound.DXResult := FDSound.ISound.SetCooperativeLevel(FForm.Handle, Level);
2603
  end;
2604
end;
2605
 
2606
procedure TCustomDXSound.SetOptions(Value: TDXSoundOptions);
2607
const
2608
  DXSoundOptions = [soGlobalFocus, soStickyFocus, soExclusive];
2609
  InitOptions: TDXSoundOptions = [soExclusive];
2610
var
2611
  OldOptions: TDXSoundOptions;
2612
begin
2613
  FOptions := Value;
2614
 
2615
  if Initialized then
2616
  begin
2617
    OldOptions := FNowOptions;
2618
 
2619
    FNowOptions := (FNowOptions - (DXSoundOptions - InitOptions)) +
2620
      (Value - InitOptions);
2621
 
2622
    FDSound.FGlobalFocus := soGlobalFocus in FNowOptions;
2623
    FDSound.FStickyFocus := soStickyFocus in FNowOptions;
2624
  end else
2625
    FNowOptions := FOptions;
2626
end;
2627
 
2628
{  TWaveCollectionItem  }
2629
 
2630
constructor TWaveCollectionItem.Create(Collection: TCollection);
2631
begin
2632
  inherited Create(Collection);
2633
  FWave := TWave.Create;
2634
  FBufferList := TList.Create;
2635
end;
2636
 
2637
destructor TWaveCollectionItem.Destroy;
2638
begin
2639
  Finalize;
2640
  FWave.Free;
2641
  FBufferList.Free;
2642
  inherited Destroy;
2643
end;
2644
 
2645
procedure TWaveCollectionItem.Assign(Source: TPersistent);
2646
var
2647
  PrevInitialized: Boolean;
2648
begin
2649
  if Source is TWaveCollectionItem then
2650
  begin
2651
    PrevInitialized := Initialized;
2652
    Finalize;
2653
 
2654
    FLooped := TWaveCollectionItem(Source).FLooped;
2655
    Name := TWaveCollectionItem(Source).Name;
2656
    FMaxPlayingCount := TWaveCollectionItem(Source).FMaxPlayingCount;
2657
 
2658
    FFrequency := TWaveCollectionItem(Source).FFrequency;
2659
    FPan := TWaveCollectionItem(Source).FPan;
2660
    FVolume := TWaveCollectionItem(Source).FVolume;
2661
 
2662
    FWave.Assign(TWaveCollectionItem(Source).FWave);
2663
 
2664
    if PrevInitialized then
2665
      Restore;
4 daniel-mar 2666
  end
2667
  else
1 daniel-mar 2668
    inherited Assign(Source);
4 daniel-mar 2669
end;
1 daniel-mar 2670
 
4 daniel-mar 2671
function TWaveCollectionItem.GetPlaying: boolean;
2672
var
2673
  Buffer: TDirectSoundBuffer;
2674
  index: integer;
2675
begin
2676
  Result := False;
2677
  if not FInitialized then Exit;
2678
  Assert(GetBuffer <> nil);
2679
  Assert(FBufferList <> nil);
2680
  if FLooped then
2681
  begin
2682
    Buffer := GetBuffer;
2683
    Assert(Buffer <> nil);
2684
    Result := Buffer.Playing;
2685
  end
2686
  else
2687
  begin
2688
    for index := 0 to FBufferList.Count - 1 do
2689
    begin
2690
      Result := TDirectSoundBuffer(FBufferList[index]).Playing;
2691
      if Result then
2692
        Break;
2693
    end;
2694
  end;
2695
end; {GetPlaying}
2696
 
1 daniel-mar 2697
function TWaveCollectionItem.GetBuffer: TDirectSoundBuffer;
2698
begin
4 daniel-mar 2699
  if FInitialized and (FBuffer = nil) then
1 daniel-mar 2700
    Restore;
2701
  Result := FBuffer;
2702
end;
2703
 
2704
function TWaveCollectionItem.GetWaveCollection: TWaveCollection;
2705
begin
2706
  Result := Collection as TWaveCollection;
2707
end;
2708
 
2709
procedure TWaveCollectionItem.Finalize;
2710
var
2711
  i: Integer;
2712
begin
2713
  if not FInitialized then Exit;
2714
  FInitialized := False;
2715
 
4 daniel-mar 2716
  for i := 0 to FBufferList.Count - 1 do
1 daniel-mar 2717
    TDirectSoundBuffer(FBufferList[i]).Free;
2718
  FBufferList.Clear;
2719
  FBuffer.Free; FBuffer := nil;
2720
end;
2721
 
2722
procedure TWaveCollectionItem.Initialize;
2723
begin
2724
  Finalize;
2725
  FInitialized := WaveCollection.Initialized;
2726
end;
2727
 
2728
function TWaveCollectionItem.CreateBuffer: TDirectSoundBuffer;
2729
begin
2730
  Result := nil;
4 daniel-mar 2731
  if GetBuffer = nil then Exit;
1 daniel-mar 2732
 
2733
  Result := TDirectSoundBuffer.Create(WaveCollection.DXSound.DSound);
2734
  try
2735
    Result.Assign(GetBuffer);
2736
  except
2737
    Result.Free;
2738
    raise;
2739
  end;
2740
end;
2741
 
2742
procedure TWaveCollectionItem.Play(Wait: Boolean);
2743
var
2744
  NewBuffer: TDirectSoundBuffer;
2745
  i: Integer;
2746
begin
2747
  if not FInitialized then Exit;
2748
 
2749
  if FLooped then
2750
  begin
2751
    GetBuffer.Stop;
2752
    GetBuffer.Position := 0;
2753
    GetBuffer.Play(True);
4 daniel-mar 2754
  end
2755
  else
1 daniel-mar 2756
  begin
2757
    NewBuffer := nil;
4 daniel-mar 2758
    for i := 0 to FBufferList.Count - 1 do
1 daniel-mar 2759
      if not TDirectSoundBuffer(FBufferList[i]).Playing then
2760
      begin
2761
        NewBuffer := FBufferList[i];
2762
        Break;
2763
      end;
4 daniel-mar 2764
 
2765
    if NewBuffer = nil then
1 daniel-mar 2766
    begin
4 daniel-mar 2767
      if FMaxPlayingCount = 0 then
1 daniel-mar 2768
      begin
2769
        NewBuffer := CreateBuffer;
4 daniel-mar 2770
        if NewBuffer = nil then Exit;
1 daniel-mar 2771
 
2772
        FBufferList.Add(NewBuffer);
4 daniel-mar 2773
      end
2774
      else
1 daniel-mar 2775
      begin
4 daniel-mar 2776
        if FBufferList.Count < FMaxPlayingCount then
1 daniel-mar 2777
        begin
2778
          NewBuffer := CreateBuffer;
4 daniel-mar 2779
          if NewBuffer = nil then Exit;
1 daniel-mar 2780
 
2781
          FBufferList.Add(NewBuffer);
4 daniel-mar 2782
        end
2783
        else
1 daniel-mar 2784
        begin
2785
          NewBuffer := FBufferList[0];
4 daniel-mar 2786
          FBufferList.Move(0, FBufferList.Count - 1);
1 daniel-mar 2787
        end;
2788
      end;
2789
    end;
2790
 
2791
    NewBuffer.Stop;
2792
    NewBuffer.Position := 0;
2793
    NewBuffer.Frequency := FFrequency;
2794
    NewBuffer.Pan := FPan;
2795
    NewBuffer.Volume := FVolume;
2796
    NewBuffer.Play(False);
2797
 
2798
    if Wait then
2799
    begin
2800
      while NewBuffer.Playing do
2801
        Sleep(10);
2802
    end;
2803
  end;
2804
end;
2805
 
2806
procedure TWaveCollectionItem.Restore;
2807
begin
4 daniel-mar 2808
  if FWave.Size = 0 then Exit;
1 daniel-mar 2809
 
2810
  if not FInitialized then
2811
  begin
2812
    if WaveCollection.Initialized then
2813
      Initialize;
2814
    if not FInitialized then Exit;
2815
  end;
2816
 
4 daniel-mar 2817
  if FBuffer = nil then
1 daniel-mar 2818
    FBuffer := TDirectSoundBuffer.Create(WaveCollection.DXSound.DSound);
2819
 
2820
  FBuffer.LoadFromWave(FWave);
2821
  FBuffer.Frequency := FFrequency;
2822
  FBuffer.Pan := FPan;
2823
  FBuffer.Volume := FVolume;
2824
end;
2825
 
2826
procedure TWaveCollectionItem.Stop;
2827
var
2828
  i: Integer;
2829
begin
2830
  if not FInitialized then Exit;
2831
 
2832
  FBuffer.Stop;
4 daniel-mar 2833
  for i := 0 to FBufferList.Count - 1 do
1 daniel-mar 2834
    TDirectSoundBuffer(FBufferList[i]).Stop;
2835
end;
2836
 
2837
procedure TWaveCollectionItem.SetFrequency(Value: Integer);
2838
begin
2839
  FFrequency := Value;
2840
  if FInitialized then
2841
    GetBuffer.Frequency := Value;
2842
end;
2843
 
2844
procedure TWaveCollectionItem.SetLooped(Value: Boolean);
2845
begin
4 daniel-mar 2846
  if FLooped <> Value then
1 daniel-mar 2847
  begin
2848
    Stop;
2849
    FLooped := Value;
2850
  end;
2851
end;
2852
 
2853
procedure TWaveCollectionItem.SetMaxPlayingCount(Value: Integer);
2854
var
2855
  i: Integer;
2856
begin
4 daniel-mar 2857
  if Value < 0 then Value := 0;
1 daniel-mar 2858
 
4 daniel-mar 2859
  if FMaxPlayingCount <> Value then
1 daniel-mar 2860
  begin
2861
    FMaxPlayingCount := Value;
2862
 
2863
    if FInitialized then
2864
    begin
4 daniel-mar 2865
      for i := 0 to FBufferList.Count - 1 do
1 daniel-mar 2866
        TDirectSoundBuffer(FBufferList[i]).Free;
2867
      FBufferList.Clear;
2868
    end;
2869
  end;
2870
end;
2871
 
2872
procedure TWaveCollectionItem.SetPan(Value: Integer);
2873
begin
2874
  FPan := Value;
2875
  if FInitialized then
2876
    GetBuffer.Pan := Value;
2877
end;
2878
 
2879
procedure TWaveCollectionItem.SetVolume(Value: Integer);
2880
begin
2881
  FVolume := Value;
2882
  if FInitialized then
2883
    GetBuffer.Volume := Value;
2884
end;
2885
 
2886
procedure TWaveCollectionItem.SetWave(Value: TWave);
2887
begin
2888
  FWave.Assign(Value);
2889
end;
2890
 
2891
{  TWaveCollection  }
2892
 
2893
constructor TWaveCollection.Create(AOwner: TPersistent);
2894
begin
2895
  inherited Create(TWaveCollectionItem);
2896
  FOwner := AOwner;
2897
end;
2898
 
2899
function TWaveCollection.GetItem(Index: Integer): TWaveCollectionItem;
2900
begin
2901
  Result := TWaveCollectionItem(inherited Items[Index]);
2902
end;
2903
 
2904
function TWaveCollection.GetOwner: TPersistent;
2905
begin
2906
  Result := FOwner;
2907
end;
2908
 
2909
function TWaveCollection.Find(const Name: string): TWaveCollectionItem;
2910
var
2911
  i: Integer;
2912
begin
2913
  i := IndexOf(Name);
4 daniel-mar 2914
  if i = -1 then
1 daniel-mar 2915
    raise EWaveCollectionError.CreateFmt(SWaveNotFound, [Name]);
2916
  Result := Items[i];
2917
end;
2918
 
2919
procedure TWaveCollection.Finalize;
2920
var
2921
  i: Integer;
2922
begin
4 daniel-mar 2923
  for i := 0 to Count - 1 do
1 daniel-mar 2924
    Items[i].Finalize;
2925
  FDXSound := nil;
2926
end;
2927
 
2928
procedure TWaveCollection.Initialize(DXSound: TCustomDXSound);
2929
var
2930
  i: Integer;
2931
begin
2932
  Finalize;
2933
  FDXSound := DXSound;
4 daniel-mar 2934
  for i := 0 to Count - 1 do
1 daniel-mar 2935
    Items[i].Initialize;
2936
end;
2937
 
2938
function TWaveCollection.Initialized: Boolean;
2939
begin
4 daniel-mar 2940
  Result := (FDXSound <> nil) and (FDXSound.Initialized);
1 daniel-mar 2941
end;
2942
 
2943
procedure TWaveCollection.Restore;
2944
var
2945
  i: Integer;
2946
begin
4 daniel-mar 2947
  for i := 0 to Count - 1 do
1 daniel-mar 2948
    Items[i].Restore;
2949
end;
2950
 
2951
type
2952
  TWaveCollectionComponent = class(TComponent)
2953
  private
2954
    FList: TWaveCollection;
2955
  published
2956
    property List: TWaveCollection read FList write FList;
2957
  end;
2958
 
2959
procedure TWaveCollection.LoadFromFile(const FileName: string);
2960
var
2961
  Stream: TFileStream;
2962
begin
2963
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
2964
  try
2965
    LoadFromStream(Stream);
2966
  finally
2967
    Stream.Free;
2968
  end;
2969
end;
2970
 
2971
procedure TWaveCollection.LoadFromStream(Stream: TStream);
2972
var
2973
  Component: TWaveCollectionComponent;
2974
begin
2975
  Clear;
2976
  Component := TWaveCollectionComponent.Create(nil);
2977
  try
2978
    Component.FList := Self;
2979
    Stream.ReadComponentRes(Component);
2980
 
2981
    if Initialized then
2982
    begin
2983
      Initialize(FDXSound);
2984
      Restore;
2985
    end;
2986
  finally
2987
    Component.Free;
2988
  end;
2989
end;
2990
 
2991
procedure TWaveCollection.SaveToFile(const FileName: string);
2992
var
2993
  Stream: TFileStream;
2994
begin
2995
  Stream := TFileStream.Create(FileName, fmCreate);
2996
  try
2997
    SaveToStream(Stream);
2998
  finally
2999
    Stream.Free;
3000
  end;
3001
end;
3002
 
3003
procedure TWaveCollection.SaveToStream(Stream: TStream);
3004
var
3005
  Component: TWaveCollectionComponent;
3006
begin
3007
  Component := TWaveCollectionComponent.Create(nil);
3008
  try
3009
    Component.FList := Self;
3010
    Stream.WriteComponentRes('DelphiXWaveCollection', Component);
3011
  finally
3012
    Component.Free;
3013
  end;
3014
end;
3015
 
3016
{  TCustomDXWaveList  }
3017
 
3018
constructor TCustomDXWaveList.Create(AOwner: TComponent);
3019
begin
3020
  inherited Create(AOwner);
3021
  FItems := TWaveCollection.Create(Self);
3022
end;
3023
 
3024
destructor TCustomDXWaveList.Destroy;
3025
begin
3026
  DXSound := nil;
3027
  FItems.Free;
3028
  inherited Destroy;
3029
end;
3030
 
3031
procedure TCustomDXWaveList.Notification(AComponent: TComponent; Operation: TOperation);
3032
begin
3033
  inherited Notification(AComponent, Operation);
4 daniel-mar 3034
  if (Operation = opRemove) and (DXSound = AComponent) then
1 daniel-mar 3035
    DXSound := nil;
3036
end;
3037
 
3038
procedure TCustomDXWaveList.DXSoundNotifyEvent(Sender: TCustomDXSound;
3039
  NotifyType: TDXSoundNotifyType);
3040
begin
3041
  case NotifyType of
3042
    dsntDestroying: DXSound := nil;
3043
    dsntInitialize: FItems.Initialize(Sender);
4 daniel-mar 3044
    dsntFinalize: FItems.Finalize;
3045
    dsntRestore: FItems.Restore;
1 daniel-mar 3046
  end;
3047
end;
3048
 
3049
procedure TCustomDXWaveList.SetDXSound(Value: TCustomDXSound);
3050
begin
4 daniel-mar 3051
  if FDXSound <> nil then
1 daniel-mar 3052
    FDXSound.UnRegisterNotifyEvent(DXSoundNotifyEvent);
3053
 
3054
  FDXSound := Value;
3055
 
4 daniel-mar 3056
  if FDXSound <> nil then
1 daniel-mar 3057
    FDXSound.RegisterNotifyEvent(DXSoundNotifyEvent);
3058
end;
3059
 
3060
procedure TCustomDXWaveList.SetItems(Value: TWaveCollection);
3061
begin
3062
  FItems.Assign(Value);
3063
end;
3064
 
4 daniel-mar 3065
{(c) 2006 Jaro Benes, Play midi from memory module}
3066
 
3067
{ TMusicDataProp }
3068
 
3069
type
3070
  TMidiDataHeader = packed record
3071
    Size: Integer;
3072
  end;
3073
 
3074
procedure TMusicDataProp.DefineProperties(Filer: TFiler);
3075
begin
3076
  inherited DefineProperties(Filer);
3077
  Filer.DefineBinaryProperty('Midi', ReadMidiData, WriteMidiData, Length(Self.FMusicData) <> 0);
3078
end;
3079
 
3080
function TMusicDataProp.GetMusicData: string;
3081
begin
3082
  SetLength(Result, Length(FMusicData));
3083
  if Length(FMusicData) <> 0 then
3084
    Move(FMusicData[1], Result[1], Length(FMusicData));
3085
end;
3086
 
3087
procedure TMusicDataProp.ReadMidiData(Stream: TStream);
3088
var
3089
  Header: TMidiDataHeader;
3090
begin
3091
  Stream.ReadBuffer(Header, SizeOf(Header));
3092
  SetLength(FMusicData, Header.Size);
3093
  Stream.ReadBuffer(FMusicData[1], Header.Size);
3094
end;
3095
 
3096
procedure TMusicDataProp.SetMusicData(const Value: string);
3097
begin
3098
  SetLength(FMusicData, Length(Value));
3099
  if Length(Value) <> 0 then
3100
    Move(Value[1], FMusicData[1], Length(Value));
3101
end;
3102
 
3103
procedure TMusicDataProp.WriteMidiData(Stream: TStream);
3104
var
3105
  Header: TMidiDataHeader;
3106
begin
3107
  Header.Size := Length(FMusicData);
3108
  Stream.WriteBuffer(Header, SizeOf(Header));
3109
  Stream.WriteBuffer(FMusicData[1], Header.Size);
3110
end;
3111
 
3112
{ TMusicListCollectionItem }
3113
 
3114
procedure TMusicListCollectionItem.Load;
3115
var
3116
  MidiFilelength: Integer;
3117
begin
3118
  // kdyby nahodou uz nejaky existoval tak ho znic
3119
  if FDirectMusicSegment <> nil then
3120
    FDirectMusicSegment := nil;
3121
  ZeroMemory(@FMusicObjDesc, SizeOf(TDMUS_OBJECTDESC));
3122
  // tohle je popisek parametru - chceme hrat z pameti
3123
  with FMusicObjDesc do
3124
  begin
3125
    dwsize := SizeOf(TDMUS_OBJECTDESC);
3126
    guidclass := CLSID_DirectMusicSegment;
3127
    //tohle jen pokud je to ze souboru
3128
    //dwvaliddata := DMUS_OBJ_CLASS or DMUS_OBJ_FULLPATH or DMUS_OBJ_FILENAME;
3129
    dwvaliddata := DMUS_OBJ_CLASS or DMUS_OBJ_MEMORY or DMUS_OBJ_LOADED;
3130
    pbMemData := @FMusicDataProp.FMusicData[1];
3131
    llMemLength := Length(FMusicDataProp.FMusicData);
3132
  end;
3133
  if FDirectMusicLoader.GetObject(FMusicObjDesc, IID_IDirectMusicSegment, FDirectMusicSegment) <> dm_ok then
3134
    raise EDXMusicError.Create('Failed to Get object for Direct music'); ;
3135
  if FDirectMusicSegment.setParam(GUID_StandardMidiFile, $FFFFFFFF, 0, 0, Pointer(FDirectMusicPerformance)) <> dm_ok then
3136
    raise EDXMusicError.Create('Failed to Set param for Direct music'); ;
3137
  if FDirectMusicSegment.setParam(GUID_Download, $FFFFFFFF, 0, 0, Pointer(FDirectMusicPerformance)) <> dm_ok then
3138
    raise EDXMusicError.Create('Failed to Set param for Direct music'); ;
3139
  FDirectMusicSegment.GetLength(MidiFilelength);
3140
  if (FActualDuration < MidiFilelength) and (FActualDuration > 0) then
3141
    FDirectMusicSegment.SetLength(FActualDuration);
3142
  if FActualStartPoint < MidiFilelength - FActualDuration then
3143
    FDirectMusicSegment.SetStartpoint(FActualStartPoint);
3144
  // jak opakovat
3145
  FDirectMusicSegment.Setrepeats(repeats - 1);
3146
end;
3147
 
3148
constructor TMusicListCollectionItem.Create(Collection: TCollection);
3149
begin
3150
  inherited Create(Collection);
3151
  CoInitialize(nil);
3152
  FMusicDataProp := TMusicDataProp.Create;
3153
  SetLength(FMusicDataProp.FMusicData, 0);
3154
  FDirectMusicPerformance := nil;
3155
  FDirectMusic := nil;
3156
  FDirectSound := nil;
3157
  FDirectMusicSegment := nil;
3158
  FDirectMusicLoader := nil;
3159
  FIsInitialized := False;
3160
end;
3161
 
3162
procedure TMusicListCollectionItem.Stop;
3163
begin
3164
  if FDirectMusicPerformance <> nil then
3165
    FDirectMusicPerformance.Stop(nil, nil, 0, 0);
3166
end;
3167
 
3168
function TMusicListCollectionItem.GetDisplayName: string;
3169
begin
3170
  Result := inherited GetDisplayName
3171
end;
3172
 
3173
procedure TMusicListCollectionItem.Play;
3174
begin
3175
  if not FIsInitialized then
3176
    Init;
3177
  Load;
3178
  if FDirectMusicPerformance <> nil then
3179
    FDirectMusicPerformance.PlaySegment(FDirectMusicSegment, 0, 0, @FDirectMusicSegmentState);
3180
end;
3181
 
3182
function TMusicListCollectionItem.IsPlaying: Boolean;
3183
begin
3184
  Result := False;
3185
  if FDirectMusicPerformance <> nil then
3186
    Result := FDirectMusicPerformance.IsPlaying(FDirectMusicSegment, FDirectMusicSegmentState) = DM_OK;
3187
end;
3188
 
3189
destructor TMusicListCollectionItem.Destroy;
3190
begin
3191
  FDirectMusicPerformance := nil;
3192
  FDirectMusic := nil;
3193
  FDirectSound := nil;
3194
  FDirectMusicSegment := nil;
3195
  FDirectMusicLoader := nil;
3196
  FMusicDataProp.Free;
3197
  CoUninitialize;
3198
  inherited Destroy;
3199
end;
3200
 
3201
procedure TMusicListCollectionItem.SetRepeats(const Value: Cardinal);
3202
begin
3203
  Frepeats := Value;
3204
end;
3205
 
3206
procedure TMusicListCollectionItem.SetStartPoint(const Value: integer);
3207
begin
3208
  FStartPoint := Value;
3209
end;
3210
 
3211
procedure TMusicListCollectionItem.SetDuration(const Value: integer);
3212
begin
3213
  FDuration := Value;
3214
end;
3215
 
3216
procedure TMusicListCollectionItem.Init;
3217
var OK: Boolean;
3218
begin
3219
  FIsInitialized := False;
3220
  OK := False;
3221
  // vytvor FDirectMusicPerformance pokud uz neni vytvoreno
3222
  if FDirectMusicPerformance = nil then
3223
    OK := CoCreateInstance(CLSID_DirectMusicPerformance, nil, CLSCTX_INPROC,
3224
      IID_IDirectMusicperformance, FDirectMusicPerformance) = DM_OK;
3225
  if not OK then Exit;
3226
  if FDirectSound <> nil then
3227
    OK := FDirectMusicPerformance.Init({$IFDEF DX7}@{$ENDIF}FDirectMusic, FDirectSound, 0) = DM_OK
3228
  else
3229
    OK := FDirectMusicPerformance.Init({$IFDEF DX7}@{$ENDIF}FDirectMusic, nil, 0) = dm_OK;
3230
  if not OK then Exit;
3231
  // vychozi midi port
3232
  // pridej pokud neni nastaven
3233
  if FDirectMusicPerformance.Addport(nil) <> DM_OK then Exit;
3234
  // zkus vytvorit loader
3235
  OK := CoCreateInstance(CLSID_DirectMusicLoader, nil, CLSCTX_Inproc,
3236
    IID_IDirectMusicLoader, FDirectMusicLoader) = DM_OK;
3237
  FIsInitialized := OK;
3238
end;
3239
 
3240
function TMusicListCollectionItem.GetMusicListCollection: TMusicListCollection;
3241
begin
3242
  Result := Collection as TMusicListCollection;
3243
end;
3244
 
3245
procedure TMusicListCollectionItem.SaveToFile(const MidiFileName: string);
3246
var F: file;
3247
begin
3248
  AssignFile(F, MidiFileName);
3249
  Rewrite(F, 1);
3250
  try
3251
    BlockWrite(F, FMusicDataProp.FMusicData[1], Length(FMusicDataProp.FMusicData));
3252
  finally
3253
    CloseFile(F);
3254
  end;
3255
end;
3256
 
3257
procedure TMusicListCollectionItem.LoadFromFile(const MidiFileName: string);
3258
var F: file; S: string; I: Integer;
3259
begin
3260
  AssignFile(F, MidiFileName);
3261
  Reset(F, 1);
3262
  try
3263
    SetLength(FMusicDataProp.FMusicData, FileSize(F));
3264
    BlockRead(F, FMusicDataProp.FMusicData[1], FileSize(F));
3265
    S := ExtractFileName(MidiFileName);
3266
    I := Pos(ExtractFileExt(S), S);
3267
    if I > 0 then S := Copy(S, 1, I - 1);
3268
    FMusicDataProp.Midiname := S;
3269
  finally
3270
    CloseFile(F);
3271
  end;
3272
  Name := ExtractFileName(MidiFileName);
3273
end;
3274
 
3275
function TMusicListCollectionItem.Size: Integer;
3276
begin
3277
  Result := Length(FMusicDataProp.FMusicData);
3278
end;
3279
 
3280
{ TMusicListCollection }
3281
 
3282
constructor TMusicListCollection.Create(AOwner: TComponent);
3283
begin
3284
  inherited Create(TMusicListCollectionItem);
3285
  FOwner := AOwner;
3286
end;
3287
 
3288
function TMusicListCollection.Add: TMusicListCollectionItem;
3289
begin
3290
  Result := TMusicListCollectionItem(inherited Add);
3291
  Result.FDirectSound := Self.FDirectSound;
3292
end;
3293
 
3294
function TMusicListCollection.GetItem(Index: Integer): TMusicListCollectionItem;
3295
begin
3296
  Result := TMusicListCollectionItem(inherited GetItem(Index));
3297
end;
3298
 
3299
procedure TMusicListCollection.SetItem(Index: Integer;
3300
  Value: TMusicListCollectionItem);
3301
begin
3302
  inherited SetItem(Index, Value);
3303
end;
3304
 
3305
procedure TMusicListCollection.Update(Item: TCollectionItem);
3306
begin
3307
  inherited Update(Item);
3308
end;
3309
 
3310
function TMusicListCollection.Find(
3311
  const Name: string): TMusicListCollectionItem;
3312
var
3313
  i: Integer;
3314
begin
3315
  i := IndexOf(Name);
3316
  if i = -1 then
3317
    raise EDXMusicError.CreateFmt('The midi document does not exist: %s.', [Name]);
3318
  Result := Items[i];
3319
end;
3320
 
3321
{$IFDEF VER4UP}
3322
function TMusicListCollection.Insert(Index: Integer): TMusicListCollectionItem;
3323
begin
3324
  Result := TMusicListCollectionItem(inherited Insert(Index));
3325
end;
3326
{$ENDIF}
3327
 
3328
function TMusicListCollection.GetOwner: TPersistent;
3329
begin
3330
  Result := FOwner;
3331
end;
3332
 
3333
procedure TMusicListCollection.Restore;
3334
begin
3335
 
3336
end;
3337
 
3338
procedure TMusicListCollection.SaveToFile(const FileName: string);
3339
var
3340
  Stream: TFileStream;
3341
begin
3342
  Stream := TFileStream.Create(FileName, fmCreate);
3343
  try
3344
    SaveToStream(Stream);
3345
  finally
3346
    Stream.Free;
3347
  end;
3348
end;
3349
 
3350
procedure TMusicListCollection.LoadFromFile(const FileName: string);
3351
var
3352
  Stream: TFileStream;
3353
begin
3354
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
3355
  try
3356
    LoadFromStream(Stream);
3357
  finally
3358
    Stream.Free;
3359
  end;
3360
end;
3361
 
3362
type
3363
  TMidiCollectionComponent = class(TComponent)
3364
  private
3365
    FList: TMusicListCollection;
3366
  published
3367
    property List: TMusicListCollection read FList write FList;
3368
  end;
3369
 
3370
procedure TMusicListCollection.SaveToStream(Stream: TStream);
3371
var
3372
  Component: TMidiCollectionComponent;
3373
begin
3374
  Component := TMidiCollectionComponent.Create(nil);
3375
  try
3376
    Component.FList := Self;
3377
    Stream.WriteComponentRes('DelphiXMidiCollection', Component);
3378
  finally
3379
    Component.Free;
3380
  end;
3381
end;
3382
 
3383
procedure TMusicListCollection.LoadFromStream(Stream: TStream);
3384
var
3385
  Component: TMidiCollectionComponent;
3386
begin
3387
  Clear;
3388
  Component := TMidiCollectionComponent.Create(nil);
3389
  try
3390
    Component.FList := Self;
3391
    Stream.ReadComponentRes(Component);
3392
    Restore;
3393
  finally
3394
    Component.Free;
3395
  end;
3396
end;
3397
 
3398
{ TDXMusic }
3399
 
3400
constructor TDXMusic.Create(AOwner: TComponent);
3401
begin
3402
  inherited Create(AOwner);
3403
  FMidis := TMusicListCollection.Create(Self);
3404
  if Assigned(FDXSound) then
3405
    FMidis.FDirectSound := FDXSound.DSound.IDSound;
3406
end;
3407
 
3408
procedure TDXMusic.SetMidis(const value: TMusicListCollection);
3409
begin
3410
  FMidis.Assign(Value);
3411
end;
3412
 
3413
destructor TDXMusic.Destroy;
3414
begin
3415
  FMidis.Free;
3416
  inherited Destroy;
3417
end;
3418
 
3419
procedure TDXMusic.SetDXSound(const Value: TDXSound);
3420
begin
3421
  FDXSound := Value;
3422
  if Assigned(FDXSound) then
3423
    FMidis.FDirectSound := FDXSound.DSound.IDSound;
3424
end;
3425
 
1 daniel-mar 3426
initialization
3427
finalization
3428
  DirectSoundDrivers.Free;
3429
  DirectSoundCaptureDrivers.Free;
3430
end.