Changeset 6 for trunk/Sound.pas
- Timestamp:
- Jan 7, 2017, 11:32:14 AM (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Sound.pas
r2 r6 4 4 5 5 uses 6 Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,MMSystem; 7 6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, MMSystem; 8 7 9 8 function PrepareSound(FileName: string): integer; 10 9 procedure PlaySound(FileName: string); 11 10 12 13 11 type 14 TSoundPlayer = class(TForm)15 private16 procedure OnMCI(var m:TMessage); message MM_MCINOTIFY;12 TSoundPlayer = class(TForm) 13 private 14 procedure OnMCI(var m: TMessage); message MM_MCINOTIFY; 17 15 end; 18 19 16 20 17 implementation … … 22 19 {$R *.DFM} 23 20 24 25 21 type 26 TSound = class27 public28 FDeviceID: word;29 FFileName: string;30 constructor Create(const FileName: string);31 destructor Destroy; override;32 procedure Play(HWND: DWORD);33 procedure Stop;34 procedure Reset;22 TSound = class 23 public 24 FDeviceID: word; 25 FFileName: string; 26 constructor Create(const FileName: string); 27 destructor Destroy; override; 28 procedure Play(HWND: DWORD); 29 procedure Stop; 30 procedure Reset; 35 31 end; 36 37 32 38 33 constructor TSound.Create(const FileName: string); 39 34 var 40 OpenParm: TMCI_Open_Parms;35 OpenParm: TMCI_Open_Parms; 41 36 begin 42 FDeviceID:=0;43 FFileName:=FileName;44 if FileExists(FFileName) then37 FDeviceID := 0; 38 FFileName := FileName; 39 if FileExists(FFileName) then 45 40 begin 46 OpenParm.dwCallback:=0;47 OpenParm.lpstrDeviceType:='WaveAudio';48 OpenParm.lpstrElementName:=PChar(FFileName);49 mciSendCommand(0, MCI_Open,50 MCI_WAIT or MCI_OPEN_ELEMENT orMCI_OPEN_SHAREABLE, integer(@OpenParm));51 FDeviceID:=OpenParm.wDeviceID;41 OpenParm.dwCallback := 0; 42 OpenParm.lpstrDeviceType := 'WaveAudio'; 43 OpenParm.lpstrElementName := PChar(FFileName); 44 mciSendCommand(0, MCI_Open, MCI_WAIT or MCI_OPEN_ELEMENT or 45 MCI_OPEN_SHAREABLE, integer(@OpenParm)); 46 FDeviceID := OpenParm.wDeviceID; 52 47 end 53 48 end; … … 55 50 destructor TSound.Destroy; 56 51 begin 57 if FDeviceID<>0 then58 mciSendCommand(FDeviceID, MCI_CLOSE, MCI_WAIT, 0);59 inherited Destroy;52 if FDeviceID <> 0 then 53 mciSendCommand(FDeviceID, MCI_CLOSE, MCI_WAIT, 0); 54 inherited Destroy; 60 55 end; 61 56 62 procedure TSound.Play(HWND: dword);57 procedure TSound.Play(HWND: DWORD); 63 58 var 64 PlayParm: TMCI_Play_Parms;59 PlayParm: TMCI_Play_Parms; 65 60 begin 66 if FDeviceID<>0 then61 if FDeviceID <> 0 then 67 62 begin 68 PlayParm.dwCallback:=HWND;69 mciSendCommand(FDeviceID, MCI_PLAY, MCI_NOTIFY, integer(@PlayParm));63 PlayParm.dwCallback := HWND; 64 mciSendCommand(FDeviceID, MCI_PLAY, MCI_NOTIFY, integer(@PlayParm)); 70 65 end 71 66 end; … … 73 68 procedure TSound.Stop; 74 69 begin 75 mciSendCommand(FDeviceID, MCI_STOP, 0, 0);70 mciSendCommand(FDeviceID, MCI_STOP, 0, 0); 76 71 end; 77 72 78 73 procedure TSound.Reset; 79 74 begin 80 mciSendCommand(FDeviceID, MCI_SEEK, MCI_SEEK_TO_START, 0);75 mciSendCommand(FDeviceID, MCI_SEEK, MCI_SEEK_TO_START, 0); 81 76 end; 82 77 83 84 78 type 85 TSoundList=array[0..99999] of TSound;79 TSoundList = array [0 .. 99999] of TSound; 86 80 87 81 var 88 nSoundList: integer; 89 SoundPlayer: TSoundPlayer; 90 SoundList: ^TSoundList; 91 PlayingSound: TSound; 92 82 nSoundList: integer; 83 SoundPlayer: TSoundPlayer; 84 SoundList: ^TSoundList; 85 PlayingSound: TSound; 93 86 94 87 procedure TSoundPlayer.OnMCI(var m: TMessage); 95 88 begin 96 if (m.wParam=MCI_Notify_Successful) and (PlayingSound<>nil) then89 if (m.wParam = MCI_Notify_Successful) and (PlayingSound <> nil) then 97 90 begin 98 PlayingSound.Reset;99 PlayingSound:=nil;91 PlayingSound.Reset; 92 PlayingSound := nil; 100 93 end; 101 94 end; 102 95 103 104 96 function PrepareSound(FileName: string): integer; 105 97 begin 106 for result:=1 to Length(FileName) do107 FileName[result]:=upcase(FileName[result]);108 result:=0;109 while (result<nSoundList) and (SoundList[result].FFileName<>FileName) do110 inc(result);111 if result=nSoundList then98 for result := 1 to Length(FileName) do 99 FileName[result] := upcase(FileName[result]); 100 result := 0; 101 while (result < nSoundList) and (SoundList[result].FFileName <> FileName) do 102 inc(result); 103 if result = nSoundList then 112 104 begin // first time this sound is played 113 if nSoundList=0 then114 ReallocMem(SoundList, 16*4)115 else if (nSoundList>=16) and (nSoundList and (nSoundList-1)=0) then116 ReallocMem(SoundList, nSoundList*(2*4));117 inc(nSoundList);118 SoundList[result]:=TSound.Create(FileName);105 if nSoundList = 0 then 106 ReallocMem(SoundList, 16 * 4) 107 else if (nSoundList >= 16) and (nSoundList and (nSoundList - 1) = 0) then 108 ReallocMem(SoundList, nSoundList * (2 * 4)); 109 inc(nSoundList); 110 SoundList[result] := TSound.Create(FileName); 119 111 end; 120 112 end; … … 122 114 procedure PlaySound(FileName: string); 123 115 begin 124 if PlayingSound<>nil then 125 exit; 126 if SoundPlayer=nil then 127 Application.CreateForm(TSoundPlayer, SoundPlayer); 128 PlayingSound:=SoundList[PrepareSound(FileName)]; 129 if PlayingSound.FDeviceID=0 then PlayingSound:=nil 130 else PlayingSound.Play(SoundPlayer.Handle); 116 if PlayingSound <> nil then 117 exit; 118 if SoundPlayer = nil then 119 Application.CreateForm(TSoundPlayer, SoundPlayer); 120 PlayingSound := SoundList[PrepareSound(FileName)]; 121 if PlayingSound.FDeviceID = 0 then 122 PlayingSound := nil 123 else 124 PlayingSound.Play(SoundPlayer.Handle); 131 125 end; 132 126 133 127 var 134 i: integer;128 i: integer; 135 129 136 130 initialization 137 nSoundList:=0; 138 SoundList:=nil; 139 PlayingSound:=nil; 140 SoundPlayer:=nil; 131 132 nSoundList := 0; 133 SoundList := nil; 134 PlayingSound := nil; 135 SoundPlayer := nil; 141 136 142 137 finalization 143 if PlayingSound<>nil then 144 begin 138 139 if PlayingSound <> nil then 140 begin 145 141 PlayingSound.Stop; 146 142 Sleep(222); 147 148 for i :=0 to nSoundList-1 do143 end; 144 for i := 0 to nSoundList - 1 do 149 145 SoundList[i].Free; 150 ReallocMem(SoundList, 0);146 ReallocMem(SoundList, 0); 151 147 152 148 end. 153
Note:
See TracChangeset
for help on using the changeset viewer.