W sekcji uses należy zadeklarować moduł MMSystem i programie wykorzystać funkcję i procedurę:
function PlayWav(const FileName: string): Boolean;
begin
Result := PlaySound(PChar(FileName), 0, SND_ASYNC);
end;
procedure StopWav;
var buffer: array[0..2] of char;
begin
buffer[0] := #0; PlaySound(Buffer, 0, SND_PURGE);
end;
//Przykład:
procedure TForm1.Button1Click(Sender: TObject);
begin
PlayWav('c:\windows\media\start.wav');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
StopWav;
end;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
MPlayer;
type TForm1 = class(TForm)
MediaPlayer1: TMediaPlayer;
procedure FormCreate(Sender: TObject);
private { Private-Deklarationen }
public
fAutoRepeat:Boolean;
procedure NotifyProc(Sender: TObject);
end;
var Form1: TForm1;
implementation {$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
MediaPlayer1.Notify := True; MediaPlayer1.OnNotify := NotifyProc; fAutorepeat := True;
end;
procedure TForm1.NotifyProc(Sender: TObject);
begin
With Sender As TMediaPlayer do begin
Case Mode of
mpStopped: IF fAutoRepeat Then (Sender as tMediaplayer).play;
end; //must set to true to enable next-time notification
Notify := True;
end; end;
end.
uses MPlayer, MMSystem;
const
MCI_SETAUDIO = $0873;
MCI_DGV_SETAUDIO_VOLUME = $4002; MCI_DGV_SETAUDIO_ITEM = $00800000;
MCI_DGV_SETAUDIO_VALUE = $01000000; MCI_DGV_STATUS_VOLUME = $4019;
type
MCI_DGV_SETAUDIO_PARMS = record
dwCallback: DWORD; dwItem: DWORD;
dwValue: DWORD; dwOver: DWORD;
lpstrAlgorithm: PChar; lpstrQuality: PChar;
end;
type
MCI_STATUS_PARMS = record
dwCallback: DWORD; dwReturn: DWORD;
dwItem: DWORD; dwTrack: DWORD;
end;
procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer); { Volume: 0 - 1000 }
var p: MCI_DGV_SETAUDIO_PARMS;
begin { Volume: 0 - 1000 }
p.dwCallback := 0; p.dwItem := MCI_DGV_SETAUDIO_VOLUME;
p.dwValue := Volume; p.dwOver := 0; p.lpstrAlgorithm := nil; p.lpstrQuality := nil;
mciSendCommand(MP.DeviceID, MCI_SETAUDIO,
MCI_DGV_SETAUDIO_VALUE or MCI_DGV_SETAUDIO_ITEM, Cardinal(@p));
end;
function GetMPVolume(MP: TMediaPlayer): Integer;
var p: MCI_STATUS_PARMS;
begin
p.dwCallback := 0; p.dwItem := MCI_DGV_STATUS_VOLUME;
mciSendCommand(MP.DeviceID, MCI_STATUS, MCI_STATUS_ITEM, Cardinal(@p));
Result := p.dwReturn; { Volume: 0 - 1000 }
end;
// Przykład:
procedure TForm1.Button1Click(Sender: TObject);
begin
SetMPVolume(MediaPlayer1, 500);
end;
Wstaw na formę TrackBar i daj jemu skalę Max = 15 i taką jego procedurę OnChage:
procedure TForm1.TrackBar1Change(Sender: TObject);
var Count, i: integer;
begin
Count := waveOutGetNumDevs; for i := 0 to Count do begin
waveOutSetVolume(i,longint(TrackBar1.Position*4369)*65536+longint(TrackBar1.Position*4369));
end; end;
Unikalny ID napędu jest zwracany w postaci 16 cyfr w standardzie HEX.
uses MMSystem, MPlayer;
procedure TForm1.Button1Click(Sender: TObject);
var mp : TMediaPlayer; msp : TMCI_INFO_PARMS; MediaString : array[0..255] of char; ret : longint;
begin
mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm;
mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := 'D:'; mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0); FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString; msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, longint(@msp));
if Ret < > 0 then begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end else Memo1.Lines.Add(StrPas(MediaString)); mp.Close;
Application.ProcessMessages;
mp.free;
end;
uses MMSystem;
procedure TForm1.Button1Click(Sender: TObject);
begin
{ wysunięcie szuflady napędu CD - zwraca 0 jak OK }
mciSendString('set cdaudio door open wait', nil, 0, handle);
{ schowanie szuflady napędu -zwraca 0 jak pomyślnie }
mciSendString('set cdaudio door closed wait', nil, 0, handle);
end;
Wprowadź na formatkę komponent TTimer i w jego procedurze OnTimer wpisz:
uses MMSystem;
procedure TForm1.Timer1Timer(Sender: TObject);
var Trk, Min, Sec: Word;
begin
with MediaPlayer1 do begin
Trk:= MCI_TMSF_TRACK(Position); Min:=MCI_TMSF_MINUTE(Position);
Sec:=MCI_TMSF_SECOND(Position); Label1.Caption:=Format('%.2d',[Trk]);
Label2.Caption:=Format('%.2d:%.2d',[Min,Sec]);
end; end;
Ten kod pokaże aktualną śźieżkę i czas.
procedure GetVolume(var volL, volR: Word);
var hWO: HWAVEOUT; waveF: TWAVEFORMATEX; vol: DWORD;
begin
volL:= 0; volR:= 0; // init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0); // open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0); // get volume
waveOutGetVolume(hWO, @vol); volL:= vol and $FFFF; volR:= vol shr 16;
waveOutClose(hWO);
end;
procedure SetVolume(const volL, volR: Word);
var hWO: HWAVEOUT; waveF: TWAVEFORMATEX; vol: DWORD;
begin // init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0); // open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0); vol:= volL + volR shl 16; // set volume
waveOutSetVolume(hWO, vol); waveOutClose(hWO);
end;
W pliku MyWave.rc piszemy:
MyWave RCDATA LOADONCALL MyWave.wav
następnie kompilujemy do pliku .RES
brcc32.exe MyWave.rc, MyWave.res.
W swoim programie piszemy:
{$R MyWave.res}
procedure RetrieveMyWave;
var hResource: THandle; pData: Pointer;
begin
hResource:=LoadResource( hInstance, FindResource(hInstance, 'MyWave', RT_RCDATA));
try pData := LockResource(hResource);
if pData = nil then raise Exception.Create('Nie mogę odtworzyć MyWave');
//tu pozycje pData kojarzymy z MyWave i teraz ten plik jest odtwarzany (Win32):
PlaySound(pData, 0, SND_MEMORY);
finally FreeResource(hResource); end;
end;
uses
{...}, vfw;
var abort: Boolean;
{$R *.DFM}
function SaveCallback(nPercent: Int): Bool; pascal;
begin
Application.ProcessMessages;
Form1.Progressbar1.Position := nPercent; //zapis na pasku postępu w procentach
if abort = True then
Result := True //jak funkcja zwraca True to proces kontynuowany
else
Result := False; //jak False to proces przerwany
end;
function TForm1.ExtractAVISound(InputFile, Outputfile: PChar): Boolean;
var PFile: IAviFile; PAvi: IAviStream; plpOptions: PAviCompressOptions;
begin
Abort := False; if Fileexists(StrPas(Outputfile)) then
begin
case MessageDlg('Plik taki istnieje. Czy mam nadpisać?', mtWarning, [mbYes, mbNo], 0) of
mrYes: begin
DeleteFile(StrPas(Outputfile)); end;
//jak nadpisać - to niszczy istniejacy plik a jak NO - to wychodzi z procedury.
mrNo: begin
Exit; end; end;
end;
try AviFileInit;
if AviFileOpen(PFile, Inputfile, 0, nil) < > 0 then //Otwiera plik AVI
begin
MessageDlg('Błąd podczas ładowania obrazu.
Być może plik jest używany przez inny proces.' + #13#10 +
'Zamknij program, sprwadź plik i spróbuj ponownie.', mtError, [mbOK], 0);
Result := False; Exit; end;
if AviFileGetStream(PFile, PAvi, StreamTypeAudio, 0) < > 0 then
begin
MessageDlg(
'Błąd! nie udało się przechwycic strumienia Audio.
Sprawdź czy ten plik ma ten strumień.', mtError, [mbOK], 0);
AviFileExit; Result := False; Exit;
end;
//zapis strumienia audio
if AviSaveV(Outputfile, nil, @SaveCallback, 1, PAvi, plpOptions) < > 0 then
begin
MessageDlg('Nie udało się zapisać strumienia audio. Operacja anulowana.', mtError, [mbOK], 0);
AviStreamRelease(PAvi); AviFileExit; Result := False; Exit; end;
finally AviStreamRelease(PAvi); AviFileExit;
end;
Result := True; //jak zwraca True to wszystko jest Ok
end;
//przykład użycia tej funkcji...
procedure TForm1.Button1Click(Sender: TObject);
begin
if ExtractAVISound(PChar('D:\test.avi'), PChar('D:\test.wav')) = True then
ShowMessage('Strumień audio zapisany pomyślnie!');
else
ShowMessage('Błąd podczas zapisu!.');
end;
(na przykładzie pliku AVI - z końcem pliku ponowne odtwarzanie)
procedure TForm1.MediaPlayer1Notify(Sender: TObject);
begin
with MediaPlayer1 do if NotifyValue = nvSuccessful then
begin
Notify := True; Play; end;
end;
uses MMSystem;
procedure TForm1.Timer1Timer(Sender: TObject);//zdarzenie komponentu TTimer
var Trk : Word; Min : Word; Sec : Word;
begin
with MediaPlayer1 do
begin
Trk := MCI_TMSF_TRACK(Position); Min := MCI_TMSF_MINUTE(Position);
Sec := MCI_TMSF_SECOND(Position); Label1.Caption := Format('%.2d',[Trk]);
Label2.Caption := Format('%.2d:%.2d',[Min,Sec]);
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MediaPlayer1.TimeFormat := tfFrames;
ShowMessage('Ilość klatek = ' + IntToStr(MediaPlayer1.Length));
MediaPlayer1.TimeFormat := tfMilliseconds;
ShowMessage('Czas trwania (milisekund) = ' + IntToStr(MediaPlayer1.Length));
end;
procedure TForm1.Button1Click(Sender: TObject);
var VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord; MaxComponentLength, FileSystemFlags : DWORD;
begin
GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo,
MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH);
Memo1.Lines.Add('VName = '+VolumeName);
Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
Memo1.Lines.Add('FSName = '+FileSystemName);
end;
Rozwiązać problem za pomocą winapi. Oto kod:
unit unit1;
interface
uses windows, messages, forms;
type tform1 = class(tform)
procedure formcreate(sender: tobject);
private
procedure wm_hotkeyhandler (var message: tmessage);
message wm_hotkey;
public{ public declarations }
end;
var form1: tform1; hk_mute,hk_volumeup,hk_volumedown,
hk_next, hk_prev, hk_stop, hk_playpause:integer;
implementation
{$r *.dfm}
procedure tform1.wm_hotkeyhandler (var message: tmessage);
var idhotkey: integer; fumodifiers: word; hotkey: word;
begin
idhotkey:= message.wparam; fumodifiers:= loword(message.lparam);
hotkey:= hiword(message.lparam);
case hotkey of
173: caption:='mute';
174: caption:='volumeup';
175: caption:='volumedown';
176: caption:='nexttrack';
177: caption:='prevtrack';
178: caption:='stop';
179: caption:='play/pause';
end; inherited;
end;
procedure tform1.formcreate(sender: tobject);
begin
hk_mute:=globaladdatom('mute');
registerhotkey(handle,hk_mute,0,173);
hk_volumeup:=globaladdatom('volumeup');
registerhotkey(handle,hk_volumeup,0,174);
hk_volumedown:=globaladdatom('volumedown');
registerhotkey(handle,hk_volumedown,0,175);
hk_next:=globaladdatom('nexttrack');
registerhotkey(handle,hk_next,0,176);
hk_prev:=globaladdatom('prevtrack');
registerhotkey(handle,hk_prev,0,177);
hk_stop:=globaladdatom('stop');
registerhotkey(handle,hk_stop,0,178);
hk_playpause:=globaladdatom('play/pause');
registerhotkey(handle,hk_playpause,0,179);
end;
end.
Te przyciski nie przechwytują jeżeli są uruchomione inne aplikacje, które używają tych przycisków, np, Winamp.
uses mmsystem;
function getwavevolume: dword;
var woc : twaveoutcaps; volume : dword;
begin
result:=0;
if waveoutgetdevcaps(wave_mapper, @woc, sizeof(woc)) =
mmsyserr_noerror then begin
if woc.dwsupport and wavecaps_volume = wavecaps_volume then
begin
waveoutgetvolume(wave_mapper, @volume);
result := volume; end; end;
end;
procedure setwavevolume(const avolume: dword);
var woc : twaveoutcaps;
begin
if waveoutgetdevcaps(wave_mapper, @woc, sizeof(woc)) =
mmsyserr_noerror then begin
if woc.dwsupport and wavecaps_volume = wavecaps_volume then
waveoutsetvolume(wave_mapper, avolume); end;
end;
procedure tform1.button1click(sender: tobject);
begin
beep;//dzwięk na speakerze
end;
procedure tform1.button2click(sender: tobject);
var leftvolume: word; rightvolume: word;
begin
leftvolume := strtoint(edit1.text); rightvolume := strtoint(edit2.text);
setwavevolume(makelong(leftvolume, rightvolume));
end;
procedure tform1.button3click(sender: tobject);
begin
caption := inttostr(getwavevolume);//na tytule siła głosu
end;
uses MPlayer, MMSystem;
const
MCI_SETAUDIO = $0873;
MCI_DGV_SETAUDIO_VOLUME = $4002;
MCI_DGV_SETAUDIO_ITEM = $00800000;
MCI_DGV_SETAUDIO_VALUE = $01000000;
MCI_DGV_STATUS_VOLUME = $4019;
type MCI_DGV_SETAUDIO_PARMS = record
dwCallback: DWORD;
dwItem: DWORD;
dwValue: DWORD;
dwOver: DWORD;
lpstrAlgorithm: PChar;
lpstrQuality: PChar;
end;
type MCI_STATUS_PARMS = record
dwCallback: DWORD;
dwReturn: DWORD;
dwItem: DWORD;
dwTrack: DWORD;
end;
procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer); { Volume: 0 - 1000 }
var p: MCI_DGV_SETAUDIO_PARMS;
begin
{ Volume: 0 - 1000 } p.dwCallback := 0;
p.dwItem := MCI_DGV_SETAUDIO_VOLUME; p.dwValue := Volume;
p.dwOver := 0; p.lpstrAlgorithm := nil; p.lpstrQuality := nil;
mciSendCommand(MP.DeviceID, MCI_SETAUDIO,
MCI_DGV_SETAUDIO_VALUE or MCI_DGV_SETAUDIO_ITEM, Cardinal(@p));
end;
function GetMPVolume(MP: TMediaPlayer): Integer;
var p: MCI_STATUS_PARMS;
begin
p.dwCallback := 0; p.dwItem := MCI_DGV_STATUS_VOLUME;
mciSendCommand(MP.DeviceID, MCI_STATUS, MCI_STATUS_ITEM, Cardinal(@p));
Result := p.dwReturn; { Volume: 0 - 1000 }
end;
// przykład wykonania
procedure TForm1.Button1Click(Sender: TObject);
begin
SetMPVolume(MediaPlayer1, 500);
end;
Wariant 1:
var DriveType: UInt;
DriveType := GetDriveType(PChar('F:\'));
if DriveType = DRIVE_CDROM then ShowMessage('Napęd F');
Wariant 2:
function GetFirstCDROM: string; {zwraca literę pierwszego napedu CD lub pusty łancuch}
var w: dword; Root: string; i: integer;
begin
w := GetLogicalDrives; Root := '#:\'; for i := 0 to 25 do
begin
Root[1] := Char(Ord('A') + i); if (W and (1 shl i)) > 0 then
if GetDriveType(Pchar(Root)) = DRIVE_CDROM then
begin
Result := Root[1]; exit; end; end; Result := '';
end
Wariant 3:
function GetFirstCDROMDrive: char;
var drivemap, mask: DWORD; i: integer; root: string;
begin
Result := #0; root := 'A:\'; drivemap := GetLogicalDrives; mask := 1;
for i := 1 to 32 do
begin
if (mask and drivemap) < > 0 then
if GetDriveType(PChar(root)) = DRIVE_CDROM then
begin
Result := root[1]; Break; end; mask := mask shl 1; Inc(root[1]); end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(GetFirstCDROMDrive);
end;
Wariant 4:
procedure TForm1.Button1Click(Sender: TObject);
var w: dword; Root: string; i: integer;
begin
w := GetLogicalDrives; Root := '#:\'; for i := 0 to 25 do
begin
Root[1] := Char(Ord('A') + i); if (W and (1 shl i)) > 0 then
if GetDriveType(Pchar(Root)) = DRIVE_CDROM then
Form1.Label1.Caption := Root; end;
end;
W WinNT/2000/XP można użyć Beep (Ton, czas trwania). A pod 9.x/Me funkcja ta nie działa, ale można wykorzystać polecenia przez porty robiąc tą obsługę uniwersalną:
unit BeepUnit;
procedure Beep(Tone, Duration: Word);
procedure Sound(Freq : Word);
procedure NoSound;
procedure SetPort(address, Value:Word);
function GetPort(address:word):word;
implementation
procedure SetPort(address, Value:Word);
var bValue: byte;
begin
bValue := trunc(Value and 255);
asm
mov dx, address
mov al, bValue
out dx, al
end; end;
function GetPort(address:word):word;
var bValue: byte;
begin
asm
mov dx, address
in al, dx
mov bValue, al
end; GetPort := bValue;
end;
procedure Sound(Freq : Word);
var B : Byte;
begin
if Freq > 18 then
begin
Freq := Word(1193181 div LongInt(Freq)); B := Byte(GetPort($61));
if (B and 3) = 0 then
begin
SetPort($61, Word(B or 3)); SetPort($43, $B6); end;
SetPort($42, Freq); SetPort($42, Freq shr 8); end;
end;
procedure NoSound;
var Value: Word;
begin
Value := GetPort($61) and $FC; SetPort($61, Value);
end;
procedure Beep(Tone, Duration: Word);
begin
if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then
Windows.Beep(Tone, Duration)
else begin
Sound(Tone); Windows.Sleep(Duration); NoSound; end;
end;
end.
procedure TForm1.mybeep(Tone: Word; Delay: Integer);
begin
asm
mov al, 0b6H
out 43H, al
mov ax,Tone
out 42h,al
ror ax,8
out 42h,al
in al, 61H
or al, 03H
out 61H, al
end; sleep(Delay);
asm
in al, 61H
and al, 0fcH
out 61H, al
end; end;
{Poniższy przykład ilustruje pobieranie i ustawianie głośności dla pierwszego napędu CDAudio. Obsługiwane są kanały lewy i prawy - zakres głośności od 0 do 65535.}
uses MMSystem;
function GetLineInHandle(AudioType: Integer): Integer;
var i: Integer;
AudioCaps: TAuxCaps;
begin
Result := 0; for i := 0 to auxGetNumDevs - 1 do
begin
auxGetDevCaps(i, @AudioCaps, SizeOf(AudioCaps));
if AudioCaps.wTechnology = AudioType then
begin
Result := i; Break; end; end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var v: DWORD;
begin
AuxGetVolume(GetLineInHandle(AUXCAPS_CDAUDIO), @v);
Edit1.Text := IntToStr(LoWord(v)); Edit2.Text := IntToStr(HiWord(v));
end;
procedure TForm1.Button2Click(Sender: TObject);
var v: DWORD;
begin
v := MakeLong(Word(StrToInt(Edit1.Text)), Word(StrToInt(Edit2.Text)));
AuxSetVolume(GetLineInHandle(AUXCAPS_CDAUDIO), v);
end;
procedure TForm1.Button3Click(Sender: TObject);
var v: DWORD;
begin
AuxGetVolume(GetLineInHandle(AUXCAPS_AUXIN), @v);
Edit3.Text := IntToStr(LoWord(v)); Edit4.Text := IntToStr(HiWord(v));
end;
procedure TForm1.Button4Click(Sender: TObject);
var v: DWORD;
begin
v := MakeLong(Word(StrToInt(Edit3.Text)), Word(StrToInt(Edit4.Text)));
AuxSetVolume(GetLineInHandle(AUXCAPS_AUXIN), v);
end;
uses MMSystem;
PlaySound(PChar('SYSTEMSTART'), 0, SND_ASYNC);
{ inne dzwięki systemowe to: SYSTEMSTART , SYSTEMEXIT , SYSTEMHAND ,
SYSTEMASTERISK , SYSTEMQUESTION , SYSTEMEXCLAMATION ,
SYSTEMWELCOME , SYSTEMDEFAULT }
Plik Wav (w formacie PCM) składa się z nagłówka oraz z danych. Nagłówek zawiera informacje o typie pliku, częstotliwośći, kanałach, itp. Same dane składają się z tablicy liczb po 8 lub 16 bitów.
type TWaveHeader = record
idRiff: array[0..3] of char;
RiffLen: longint;
idWave: array[0..3] of char;
idFmt: array[0..3] of char;
InfoLen: longint;
WaveType: smallint;
Ch: smallint;
Freq: longint;
BytesPerSec: longint;
align: smallint;
Bits: smallint;
end;
TDataHeader = record
idData: array[0..3] of char;
DataLen: longint;
end;
//procedura odczytu nagłówka pliku wav
procedure ReadWaveHeader(Stream: TStream; var SampleCount, SamplesPerSec: integer;
var BitsPerSample, Channeles: smallint);
var
WaveHeader: TWaveHeader; DataHeader: TDataHeader;
begin
Stream.Read(WaveHeader, sizeof(TWaveHeader));
with WaveHeader do
begin
if idRiff < > 'RIFF' then raise EReadError.Create('Wrong idRIFF');
if idWave < > 'WAVE' then raise EReadError.Create('Wrong idWAVE');
if idFmt < > 'fmt ' then raise EReadError.Create(' Wrong idFmt');
if WaveType < > 1 then raise EReadError.Create('Unknown format');
Channeles := Ch; SamplesPerSec := Freq;
BitsPerSample := Bits; Stream.Seek(InfoLen - 16, soFromCurrent);
end;
Stream.Read(DataHeader, sizeof(TDataHeader));
if DataHeader.idData = 'fact' then
begin
Stream.Seek(4, soFromCurrent);
Stream.Read(DataHeader, sizeof(TDataHeader));
end;
with DataHeader do
begin
if idData < > 'data' then
raise EReadError.Create('Wrong idData');
SampleCount := DataLen div (Channeles * BitsPerSample div 8)
end; end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenDialog1.Filter := 'Pliki WAV|*.wav';
end;
procedure TForm1.Button1Click(Sender: TObject);
var F: TFileStream; SampleCount, SamplesPerSec: integer;
BitsPerSample, Channeles: smallint;
begin
// wywołanie OpenDialog1:
if not OpenDialog1.Execute then Exit;
try
// odczyt pliku:
F := TFileStream.Create(OpenDialog1.FileName, fmOpenRead);
// odczyt nagłówka:
ReadWaveHeader(F, SampleCount, SamplesPerSec, BitsPerSample, Channeles);
F.Free; Memo1.Clear;
// wypełnienie Memo informacjami o pliku:
Memo1.Lines.Add('SampleCount: ' + IntToStr(SampleCount));
Memo1.Lines.Add(Format('Length: %5.3f sec', [SampleCount / SamplesPerSec]));
Memo1.Lines.Add('Channeles: ' + IntToStr(Channeles));
Memo1.Lines.Add('Freq: ' + IntToStr(SamplesPerSec));
Memo1.Lines.Add('Bits: ' + IntToStr(BitsPerSample));
except
raise Exception.Create('Problemy z odczytem pliku');
end; end;
uses mmsystem;
//przed wywołaniem tej procedury urządzenia muszą być włączone.
procedure GetWaveOutDevices(DeviceNames: TStrings);
var DNum: Integer; i: Integer; Caps: TWaveOutCapsA;
begin
DNum := waveOutGetNumDevs; // liczba urządzeń
for i := 0 to DNum - 1 do // ich nazwy
begin
waveOutGetDevCaps(i, @Caps, SizeOf(TWaveOutCapsA));
DeviceNames.Add(string(Caps.szPname));
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GetWaveOutDevices(Listbox1.Items);
end;
type TMP3Tag = record
FileName, Title, Artist, Album, Year, Comment: string;
end;
function GetMP3Tag(fn: string): TMP3Tag;
var tag: array[0..127] of char; f: file; i: byte; s: string;
procedure DelSpace(var s: string);
begin // usuwa spacje i #0 na końcu.
if length(s) = 0 then exit;
while s[length(s)] in [' ', #0] do
begin
delete(s, length(s), 1); if s = '' then break; end;
end;
begin
result.FileName := fn;
result.Title := '';
result.Artist := '';
result.Album := '';
result.Year := '';
result.Comment := '';
AssignFile(F, fn); // otwarcie pliku ze sprawdzeniem jego istnienia
{$I-} Reset(F, 1); Seek(F, FileSize(F) - 128); // odczyt ostatnich 128 bajtów
BlockRead(f, tag, 128); CloseFile(F);
{$I+}
if IOResult < > 0 then begin exit; end;
s := '';
for i := 0 to 127 do s := s + tag[i];
if copy(s, 1, 3) = 'TAG' then //jeżeli jest Tag to go odczytuje
begin
result.Title := copy(s, 4, 30);
DelSpace(result.title);
result.Artist := copy(s, 34, 30);
DelSpace(result.artist);
result.Album := copy(s, 64, 30);
DelSpace(result.album);
result.Year := copy(s, 94, 4);
DelSpace(result.year);
result.Comment := copy(s, 98, 30);
DelSpace(result.comment);
end;
end;
//przykład wywołania:
var Tag: TMP3Tag;
begin
if OpenDialog1.Execute then Tag := GetMP3Tag(OpenDialog1.FileName);
end;
uses MMSystem;
procedure TForm1.Timer1Timer(Sender: TObject);
var Trk, Min, Sec: Word;
begin
with MediaPlayer1 do
begin
Trk := MCI_TMSF_TRACK(Position); Min := MCI_TMSF_MINUTE(Position);
Sec := MCI_TMSF_SECOND(Position); label1.Caption := Format('%.2d', [Trk]);
Label2.Caption := Format('%.2d:%.2d', [Min, Sec]);
end; end;
uses MMSystem;
function GetWaveVolume(var LVol: DWORD; var RVol: DWORD): Boolean;
var WaveOutCaps: TWAVEOUTCAPS; Volume: DWORD;
begin
Result := False;
if WaveOutGetDevCaps(WAVE_MAPPER, @WaveOutCaps, SizeOf(WaveOutCaps)) = MMSYSERR_NOERROR then
if WaveOutCaps.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
begin
Result := WaveOutGetVolume(WAVE_MAPPER, @Volume) = MMSYSERR_NOERROR;
LVol := LoWord(Volume); RVol := HiWord(Volume);
end;
end;
{ Funkcja waveOutGetDevCaps pobiera możliwości urządzenia audio a funkcja waveOutGetVolume pobiera aktualny poziom głośności.}
function SetWaveVolume(const AVolume: DWORD): Boolean;
var WaveOutCaps: TWAVEOUTCAPS;
begin
Result := False;
if WaveOutGetDevCaps(WAVE_MAPPER, @WaveOutCaps, SizeOf(WaveOutCaps)) = MMSYSERR_NOERROR then
if WaveOutCaps.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
Result := WaveOutSetVolume(WAVE_MAPPER, AVolume) = MMSYSERR_NOERROR;
end;
{ AVolume: ustawianie głośności. LVol, RVol - lewego i prawego kanału oddzielnie od 0000 (cisza) do 65535 (pełna głośność). Przy odtwarzaniu jednokanałowym pracuje kanał lewy.}
// ustawianie głośności:
procedure TForm1.Button1Click(Sender: TObject);
var LVol: Word; RVol: Word;
begin
LVol := SpinEdit1.Value; // max. is 65535
RVol := SpinEdit2.Value; // max. is 65535
SetWaveVolume(MakeLong(LVol, RVol));
end;
// odczyt dzwięku:
procedure TForm1.Button2Click(Sender: TObject);
var LVol: DWORD; RVol: DWORD;
begin
if GetWaveVolume(LVol, RVol) then
begin
SpinEdit1.Value := LVol; SpinEdit2.Value := RVol; end;
end;
uses MMSystem;
procedure SendMCICommand(Cmd: string);
var RetVal: Integer; ErrMsg: array[0..254] of char;
begin
RetVal := mciSendString(PChar(Cmd), nil, 0, 0);
if RetVal < > 0 then
begin
{pojawia się komunikat o zwracanej wartości}
mciGetErrorString(RetVal, ErrMsg, 255);
MessageDlg(StrPas(ErrMsg), mtError, [mbOK], 0);
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMCICommand('open waveaudio shareable');
SendMCICommand('play "C:xyzBackgroundMusic.wav"');
SendMCICommand('play "C:xyzAnotherMusic.wav"');
SendMCICommand('close waveaudio');
end;
Wariant 1:
uses MMSystem;
procedure SetVolume(const volL, volR: Word);
var hWO: HWAVEOUT; waveF: TWAVEFORMATEX; vol: DWORD;
begin
// init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0);
// open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0); vol := volL + volR shl 16;
// set volume
waveOutSetVolume(hWO, vol); waveOutClose(hWO);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetVolume(14000, 14000);
end;
Wariant 2 - według http://forum.vingrad.ru:
uses mmsystem;
function GetWaveVolume: DWord;
var Woc: TWAVEOUTCAPS; Volume: DWord;
begin
result := 0;
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
begin
WaveOutGetVolume(WAVE_MAPPER, @Volume); Result := Volume; end;
end;
procedure SetWaveVolume(const AVolume: DWord);
var Woc: TWAVEOUTCAPS;
begin
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
WaveOutSetVolume(WAVE_MAPPER, AVolume);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Beep;
end;
procedure TForm1.Button2Click(Sender: TObject);
var LeftVolume: Word; RightVolume: Word;
begin
LeftVolume := StrToInt(Edit1.Text); RightVolume := StrToInt(Edit2.Text);
SetWaveVolume(MakeLong(LeftVolume, RightVolume));
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Caption := IntToStr(GetWaveVolume);
end;
Wariant 3 - zmiana programowa autor Olookin
procedure TForm1.TrackBar1Change(Sender: TObject);
var s: dword; a,b: word; h: hWnd;
begin
a:=trackbar1.position; b:=trackbar2.position;
s:=(a shl 16) or b; waveOutSetVolume(h,s);
end;
Wariant 4:
procedure SetVolume(X: Word);
var iErr: Integer; i: integer; a: TAuxCaps;
begin
for i := 0 to auxGetNumDevs do
begin
auxGetDevCaps(i, Addr(a), SizeOf(a));
if a.wTechnology = AUXCAPS_CDAUDIO then break;
end;
// ustanawiany taką samą głośność dla lewego i prawego kanalu.
// VOLUME := LEFT*$10000 + RIGHT*1
iErr := auxSetVolume(i, (X * $10001)); if (iErr< >0) then
ShowMessage('No audio devices are available!');
end;
function GetVolume: Word;
var iErr: Integer; i: integer; a: TAuxCaps; vol: word;
begin
for i := 0 to auxGetNumDevs do
begin
auxGetDevCaps(i, Addr(a), SizeOf(a));
if a.wTechnology = AUXCAPS_CDAUDIO then break;
end;
iErr := auxGetVolume(i, addr(vol)); GetVolume := vol;
if (iErr < > 0) then
ShowMessage('No audio devices are available!');
end;
W TEdit będzie pokazana nazwa katalogu a w TListBox lista tytułów i czas odtwarzania wszystkich plikow katalogu.
procedure ScanMP3Folder (const AFolder : string; AMP3List : TStrings);
var ds : TDirectoryScanner; a : TAudioInfo; Descr : string; i : integer;
begin
ds := TDirectoryScanner.Create; a := TAudioInfo.Create;
try
ds.Recursive := True; ds.RegExprMask := '.mp[23]';
ds.BuildFileList (AFolder);
for i := 0 to ds.Count - 1 do
begin
a.LoadFromFile (ds.Item [i].name); if a.ID3.Ok then
Descr := a.ID3.Artist + ' - ' + a.ID3.Title
else
Descr := ExtractFileName (ds.Item [i].name);
Descr := Descr + Format (' (%d sec)', [a.MpegDuration div 1000]);
AMP3List.Add (Descr); end;
finally begin a.Free; ds.Free; end; end;
end;
//przykład wywołania:
ScanMP3Folder(Edit1.Text, ListBox1.Items);
uses MMSystem;
// odtwarza Midi
procedure TForm1.Button1Click;
const FileName = 'C:YourFile.mid';
begin
MCISendString(PChar('play ' + FileName), nil, 0, 0);
end;
// zatrzymuje odtwarzanie MIDI
procedure TForm1.Button1Click;
const FileName = 'C:YourFile.mid';
begin
MCISendString(PChar('stop ' + FileName), nil, 0, 0);
end;
W systemie Windows MMSystem musi byc zainstalowany sterownik dekodera MPEG, który wykorzysta komponent TMediaPlayer.
procedure TForm1.Button1Click(Sender: TObject);
begin
with MediaPlayer1 do
begin
Filename := 'C:Downloaddelphiworld.mpg'; Open;
Display := Panel1; DisplayRect := Panel1.ClientRect; Play;
end; end;
Po prostu trzeba go przegrać na inną formę i tą ustawić w reżimie pełnoekranowym (wsMaximized).
{kod na Form 1}
uses Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin
Form2.Show; Form2.WindowState := wsMaximized;
Form2.MediaPlayer1.Notify := false;
Form2.MediaPlayer1.Display := Form2.Panel1;
Form2.MediaPlayer1.FileName := 'C:TheWallDELCAR2.AVI';
Form2.MediaPlayer1.Open;
Form2.MediaPlayer1.DisplayRect := Form2.ClientRect;
Form2.MediaPlayer1.Play;
end;
{kod na Form 2}
procedure TForm2.MediaPlayer1Notify(Sender: TObject);
begin
if MediaPlayer1.NotifyValue = nvSuccessful then Form2.Close;
end;
Przykład pokazuje jak otworzyć plik wideo, jak chwycić ramkę z filmu i jak zapisać ramkę na dysku jako plik. BMP.
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type TForm1 = class(TForm)
Panel1: TPanel;
OpenVideo: TButton;
CloseVideo: TButton;
GrabFrame: TButton;
SaveBMP: TButton;
StartAVI: TButton;
StopAVI: TButton;
SaveDialog1: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure OpenVideoClick(Sender: TObject);
procedure CloseVideoClick(Sender: TObject);
procedure GrabFrameClick(Sender: TObject);
procedure SaveBMPClick(Sender: TObject);
procedure StartAVIClick(Sender: TObject);
procedure StopAVIClick(Sender: TObject);
private { Private declarations }
hWndC: THandle;
CapturingAVI: bool;
public { Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
const WM_CAP_START = WM_USER;
const WM_CAP_STOP = WM_CAP_START + 68;
const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;
const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;
const WM_CAP_SAVEDIB = WM_CAP_START + 25;
const WM_CAP_GRAB_FRAME = WM_CAP_START + 60;
const WM_CAP_SEQUENCE = WM_CAP_START + 62;
const WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;
function capCreateCaptureWindowA(lpszWindowName: PCHAR; dwStyle: longint;
x: integer; y: integer; nWidth: integer; nHeight: integer; ParentWin: HWND;
nId: integer): HWND; stdcall external 'AVICAP32.DLL';
procedure TForm1.FormCreate(Sender: TObject);
begin
CapturingAVI := false; hWndC := 0;
SaveDialog1.Options := [ofHideReadOnly, ofNoChangeDir, ofPathMustExist]
end;
procedure TForm1.OpenVideoClick(Sender: TObject);
begin
hWndC := capCreateCaptureWindowA('My Own Capture Window',
WS_CHILD or WS_VISIBLE, Panel1.Left, Panel1.Top, Panel1.Width,
Panel1.Height, Form1.Handle, 0);
if hWndC < > 0 then
SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
end;
procedure TForm1.CloseVideoClick(Sender: TObject);
begin
if hWndC < > 0 then
begin
SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0); hWndC := 0;
end; end;
procedure TForm1.GrabFrameClick(Sender: TObject);
begin
if hWndC < > 0 then
SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0);
end;
procedure TForm1.SaveBMPClick(Sender: TObject);
begin
if hWndC < > 0 then
begin
SaveDialog1.DefaultExt := 'bmp';
SaveDialog1.Filter := 'Bitmap files (*.bmp)|*.bmp';
if SaveDialog1.Execute then
SendMessage(hWndC, WM_CAP_SAVEDIB, 0,
longint(pchar(SaveDialog1.FileName))); end;
end;
procedure TForm1.StartAVIClick(Sender: TObject);
begin
if hWndC < > 0 then
begin
SaveDialog1.DefaultExt := 'avi';
SaveDialog1.Filter := 'AVI files (*.avi)|*.avi';
if SaveDialog1.Execute then
begin
CapturingAVI := true;
SendMessage(hWndC, WM_CAP_FILE_SET_CAPTURE_FILEA, 0,
Longint(pchar(SaveDialog1.FileName)));
SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0); end; end;
end;
procedure TForm1.StopAVIClick(Sender: TObject);
begin
if hWndC < > 0 then
begin
SendMessage(hWndC, WM_CAP_STOP, 0, 0); CapturingAVI := false; end;
end;
end.
var myjoy: tjoyinfo;
begin
joygetpos(joystickid1,@myjoy); trackbar1.position := myjoy.wypos;
trackbar2.position := myjoy.wxpos;
radiobutton1.checked := (myjoy.wbuttons and joy_button1) >0;
radiobutton2.checked := (myjoy.wbuttons and joy_button2) >0;
end;
Po pierwsze, należy utworzyć pusty plik audio, np. w Windows Audio Recorder, który będzie miał takie opcje jak plik wynikowy a następnie użyć TMediaPlayer (tu jako Media):
procedure TForm1.btRecordClick(Sender: TObject);
begin
with Media do
begin
FileName := 'd:\tymczas.wav'; { ustaw jako plik tymczasowy }
Open; { Otwórz..... }
Wait := False; StartRecording; { Start odtwarzania. }
end;
end;
procedure TForm1.btStopClick(Sender: TObject);
begin
with Media do
begin
Stop; { Stop odtwarzania. }
FileName := 'd:\pliczek.wav'; { zmiana nazwy pliku jeżeli ma być zapisany. }
Save; Close; end; { zapis i zamknięcie pliku. }
end;
uses mmSystem;
{....}
procedure TForm1.Button1Click(Sender: TObject); // Record
begin
mciSendString('OPEN NEW TYPE WAVEAUDIO ALIAS mysound', nil, 0, Handle);
mciSendString('SET mysound TIME FORMAT MS ' + // set time
'BITSPERSAMPLE 8 ' + // 8 Bit
'CHANNELS 1 ' + // MONO
'SAMPLESPERSEC 8000 ' + // 8 KHz
'BYTESPERSEC 8000', // 8000 Bytes/s
nil, 0, Handle);
mciSendString('RECORD mysound', nil, 0, Handle)
end;
procedure TForm1.Button2Click(Sender: TObject); // Stop
begin
mciSendString('STOP mysound', nil, 0, Handle)
end;
procedure TForm1.Button3Click(Sender: TObject); // Save
var verz: String;
begin
GetDir(0, verz);
mciSendString(PChar('SAVE mysound ' + verz + '/test.wav'), nil, 0, Handle);
mciSendString('CLOSE mysound', nil, 0, Handle)
end;
Wariant 1:
uses MPlayer, MMsystem;
type EMyMCIException = class(Exception);
TWavHeader = record
Marker1: array[0..3] of Char;
BytesFollowing: Longint;
Marker2: array[0..3] of Char;
Marker3: array[0..3] of Char;
Fixed1: Longint;
FormatTag: Word;
Channels: Word;
SampleRate: Longint;
BytesPerSecond: Longint;
BytesPerSample: Word;
BitsPerSample: Word;
Marker4: array[0..3] of Char;
DataBytes: Longint;
end;
procedure TForm1.Button1Click(Sender: TObject);
var Header: TWavHeader;
begin
with TFileStream.Create('C:\SomeFile.wav', fmOpenRead) do
try ReadBuffer(Header, SizeOf(Header));
finally Free; end;
ShowMessage(FloatToStr((Int64(1000) * header.DataBytes div header.BytesPerSecond) / 1000));
end;
Wariant 2:
function GetWaveLength(WaveFile: string): Double;
var groupID: array[0..3] of char; riffType: array[0..3] of char; BytesPerSec: Integer;
Stream: TFileStream; dataSize: Integer; // chunk seeking function; -1 means: chunk not found
function GotoChunk(ID: string): Integer;
var chunkID: array[0..3] of char; chunkSize: Integer;
begin
Result := -1; with Stream do
begin
Position := 12; // index of first chunk
repeat // read next chunk
Read(chunkID, 4); Read(chunkSize, 4); if chunkID < > ID then // skip chunk
Position := Position + chunkSize;
until(chunkID = ID) or (Position >= Size); if chunkID = ID then
// chunk found, return chunk size
Result := chunkSize; end;
end;
begin
Result := -1;
Stream := TFileStream.Create(WaveFile, fmOpenRead or fmShareDenyNone);
with Stream do
try Read(groupID, 4); Position := Position + 4; // skip four bytes (file size)
Read(riffType, 4);
if(groupID = 'RIFF') and (riffType = 'WAVE') then
begin
// search for format chunk
if GotoChunk('fmt') < > -1 then
begin
Position := Position + 8; Read(BytesPerSec, 4); // found it
dataSize := GotoChunk('data'); //search for data chunk
if dataSize < > -1 then // found it
Result := dataSize / BytesPerSec end end
finally Free; end;
end;
//i przykład wywołania.....
procedure TForm1.Button1Click(Sender: TObject);
var Seconds: Integer;
begin
Seconds := Trunc(GetWaveLength(Edit1.Text));
//gets only the Integer part of the length
Label1.Caption := SecondsToTimeStr(Seconds);
end;
Wariant 3:
function SecondsToTimeStr(RemainingSeconds: Integer): string;
var Hours, Minutes, Seconds: Integer;
HourString, MinuteString, SecondString: string;
begin // Calculate Minutes
Seconds := RemainingSeconds mod 60; Minutes := RemainingSeconds div 60;
Hours := Minutes div 60; Minutes := Minutes - (Hours * 60);
if Hours < 10 then HourString := '0' + IntToStr(Hours) + ':'
else
HourString := IntToStr(Hours) + ':';
if Minutes < 10 then MinuteString := '0' + IntToStr(Minutes) + ':'
else
MinuteString := IntToStr(Minutes) + ':';
if Seconds < 10 then SecondString := '0' + IntToStr(Seconds)
else
SecondString := IntToStr(Seconds);
Result := HourString + MinuteString + SecondString;
end;
//i przykład wywołania......
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := SecondsToTimeStr(Trunc(GetWaveLength(Edit1.Text)));
end;