Не дайте умереть без стипендии:)

[DimaKa]

Если кто то сможет написать комментарии к проге я буду очень благодарен!


unit main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Spin, ComCtrls, Buttons,
////////////////////
MMSystem; // needed
///////////////////

const maxbuf=44100*20; //= 10 seconds for mono 16 bit 44.1kHz sygnal

type
TFMain = class(TForm)
GroupBox1: TGroupBox;
TrackBar: TTrackBar;
SpinEdit: TSpinEdit;
BStart: TSpeedButton;
r2: TRadioButton;
r3: TRadioButton;
Label1: TLabel;
BExit: TButton;
TrackBar1: TTrackBar;
lblVol: TLabel;
procedure SpinEditChange(Sender: TObject);
procedure TrackBarChange(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure BStartClick(Sender: TObject);
procedure r1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure BExitClick(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
private
hDevice:THandle;
buf:array[0..maxbuf-1] of smallint;
procedure MMWOMDONE(var m:TMessage); message MM_WOM_DONE;
public
mulouble;
procedure start;
procedure stop;
procedure ProgramDevice;
end;

var
FMain: TFMain;

implementation

{$R *.DFM}

var
volume: LongWord; // старшее слово - правый канал,
// младшее - левый.

procedure TFMain.SpinEditChange(Sender: TObject);
begin
TrackBar.position:=spinedit.value;
if BStart.down then programDevice;
end;

procedure TFMain.TrackBarChange(Sender: TObject);
begin
SpinEdit.value:=TrackBar.position;
if BStart.down then programDevice;
end;

procedure TFMain.FormKeyPress(Sender: TObject; var Key: Char);
begin
if key=#13 then begin //enter=старт/стоп
BStart.down:=not BStart.down;
BStart.click;
end;
if key=#27 then begin //esc=стоп
stop;
end;
end;

procedure TFMain.start;
var wfe:TWaveFormatEx;
err:integer;
begin
BStart.down:=true;
with wfe do begin
wFormatTag:=WAVE_FORMAT_PCM;
nChannels:=1;
nSamplesPerSec:=44100;
nBlockAlign:=2;
wBitsPerSample:=16;
nAvgBytesPerSec:=nSamplesPerSec*nBl ockAlign;
cbSize:=0;
end;
err:=WaveOutOpen(@hDevice,wave_mapp er,@wfe,self.handle,0,callback_wind ow);
if err <> mmSyserr_noerror then begin
BStart.down:=false;
Application.MessageBox('Cannot open wave device. Maybe it is allready captured by another program or not present.',
'Error',mb_ok or mb_iconstop);
exit;
end;

ProgramDevice;
end;

procedure TFMain.stop;
begin
BStart.down:=false;
WaveOutReset(hDevice);
WaveOutClose(hDevice);
end;

procedure TFMain.BStartClick(Sender: TObject);
begin
if BStart.down then start else stop;
end;

procedure TFMain.ProgramDevice;
const hdr:TWaveHdr=();
var i,err:integer;
vouble;

function Getvalueouble;
begin
result:=spinedit.value*mul;
if result<15 then result:=15;
end;

function CalcCycles:integer;
// The problem is to determine the amount of sine wave cycles of F Hz
// which take almost whole number of carrier frequency (44.1kHz).
const epsilon=0.01;
var f,n,dnouble;
ni:integer;
begin
f:=GetValue;
n:=44100/f; dn:=n;
ni:=1;
while (abs(round(n)-n)>epsilon) and (ni<100) do begin
inc(ni);
n:=n+dn;
end;
result:=round(n);
end;



begin
err:=WaveOutReset(hDevice);

with hdr do begin
lpdata:=@buf;
dwBufferLength:=CalcCycles()*2;
dwFlags:=WHDR_BEGINLOOP or WHDR_ENDLOOP;
dwLoops:=100000000;
end;

v:=2*pi*GetValue/44100;
for i:=0 to hdr.dwBufferLength div 2 do begin
buf[i]:=round(32700*sin(i*v));
end;

err:=WaveOutPrepareHeader(hDevice,@ hdr,sizeof(hdr));
err:=WaveOutWrite(hDevice,@hdr,size of(hdr));
end;

procedure TFMain.MMWOMDONE(var m:TMessage);
begin
WaveOutUnPrepareHeader(m.wparam,poi nter(m.lparam),sizeof(TWaveHdr));
end;


procedure TFMain.r1Click(Sender: TObject);
begin
if r2.checked then begin
mul:=0.1; label1.caption:='15 .. 1000 Гц';
end
else begin
mul:=0.01; label1.caption:='15 .. 100 Гц';
end;
if BStart.down then programDevice;
end;

procedure TFMain.FormCreate(Sender: TObject);
begin

r1click(self);
TrackBar1.Position := 7;
// старшее слово переменной volume - правый канал,
// младшее - левый
volume := (TrackBar1.Position - TrackBar1.Max+1)* 6500;
volume := volume + (volume shl 16);
waveOutSetVolume(WAVE_MAPPER,volume ); // уровень сигнала

end;

procedure TFMain.BExitClick(Sender: TObject);
begin
Close;
end;

procedure TFMain.TrackBar1Change(Sender: TObject);
begin
volume := 6500* (TrackBar1.Max - TrackBar1.Position);
volume := volume + (volume shl 16);
waveOutSetVolume(WAVE_MAPPER,volume );

end;






end.