用声卡发声

用声卡发声
unit MainForm;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls, MMSystem, mmErrMsg;
const
sweep_time = 45; // seconds for slow sweep
sample_rate = 44100; // i.e. best CD quality
sine_table_samples = 1 shl 15; // number of samples in sine table
max_buffer_samples = 32000; // reasonable size of output buffer (< 64K)
open_error = 'Error opening waveform audio!';
mem_error = 'Error allocating memory!';
type
audio_sample = -32767..32767; // for 16-bit audio
type
PSineTable = ^TSineTable; // sine value store
TSineTable = array [0..sine_table_samples-1] of audio_sample;
PBuffer = ^TBuffer; // output buffer type
TBuffer = array [0..max_buffer_samples-1] of audio_sample;
levels = (dB0, dB3, dB6, dB9, dB12, dB15, dB18, dB20); // output levels
　
type
TForm1 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
btnExit: TButton;
btnStart: TButton;
grpOutputLevel: TRadioGroup;
edtF1: TEdit;
lblFnow: TLabel;
procedure btnExitClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure grpOutputLevelClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnStartClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure edtF1Change(Sender: TObject);
private
{ Private declarations }
angle: integer; // current sine wave angle
sine_table: PSineTable; // sine-wave values are pre-stored in this array
p_wave_hdr1: PWaveHdr; // wave headers
p_wave_hdr2: PWaveHdr;
p_buffer1: PBuffer; // output buffers
p_buffer2: PBuffer;
hWave_hdr1: HGlobal;
hWave_hdr2: HGlobal;
hBuffer1: HGlobal;
hBuffer2: HGlobal;
buffer_bytes: integer; // max number of bytes in each output buffer
f_min: integer; // limits of sweep range
buffers_written, buffers_played: integer; // for tracking the slow sweep
all_written: boolean; // so we know when to stop the sweep
f:extended;
hWave_out: HWaveOut; // handle to wave out device
pcm: TWaveFormatEx; // wave format descriptor
sweep_running: boolean;
shutoff: boolean;
closing: boolean;
sine_table_done: boolean;
closed: boolean;
level: levels;
// speed: speeds;
// range: ranges;
procedure restart_sweep;
procedure stop_sweep;
procedure start_sweep;
// call-backs from waveform out functions
procedure mm_wom_Open (var Msg: TMessage); message mm_wom_open;
procedure mm_wom_Done (var Msg: TMessage); message mm_wom_done;
procedure mm_wom_Close (var Msg: TMessage); message mm_wom_close;
// function fill_single_sweep_bfr (bfr: PBuffer; num_freqs: integer):
integer;
procedure fill_buffer_with_sinewave (bfr: PBuffer; index, samples:
integer);
procedure write_next_buffer (header: PWaveHdr);
procedure do_sine_table;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
　
procedure TForm1.FormCreate(Sender: TObject);
begin
// speed := no_sweep;
// set the default positions for the RadioGroup boxes, this forces the
// dependant variables and the label captions to be set
　
// get the memory required for wave headers
// this code is probably irrelevant in the Win32 environment
hWave_hdr1 := GlobalAlloc (gHnd or gMem_Share, SizeOf (TWaveHdr));
p_wave_hdr1 := pWaveHdr (GlobalLock (hWave_hdr1));
hWave_hdr2 := GlobalAlloc (gHnd or gMem_Share, SizeOf (TWaveHdr));
p_wave_hdr2 := pWaveHdr (GlobalLock (hWave_hdr2));
// estimate of reasonable output buffer size
buffer_bytes := 2 * round (1.2 * sample_rate);
if buffer_bytes > 2 * max_buffer_samples
then buffer_bytes := 2 * max_buffer_samples;
// get the memory required for output buffers
hBuffer1 := GlobalAlloc (gHnd or gMem_Share, buffer_bytes);
p_buffer1 := pBuffer (GlobalLock (hBuffer1));
hBuffer2 := GlobalAlloc (gHnd or gMem_Share, buffer_bytes);
p_buffer2 := pBuffer (GlobalLock (hBuffer2));
hWave_out := 0;
// get the memory for the sine-wave table and note it hasn't been built, yet
GetMem (sine_table, SizeOf (TSineTable));
sine_table_done := false;
// set other state variables
shutoff := false;
closing := false;
sweep_running := false;
end;
　
procedure TForm1.FormDestroy(Sender: TObject);
begin
shutoff := true;
GlobalUnlock (hWave_hdr1); GlobalFree (hWave_hdr1);
GlobalUnlock (hBuffer1); GlobalFree (hBuffer1);
GlobalUnlock (hWave_hdr2); GlobalFree (hWave_hdr2);
GlobalUnlock (hBuffer2); GlobalFree (hBuffer2);
FreeMem (sine_table, SizeOf (TSineTable));
end;
　
procedure TForm1.btnExitClick(Sender: TObject);
begin
Close;
end;
　
procedure TForm1.grpOutputLevelClick(Sender: TObject);
var
current: string;
begin
current := grpOutputLevel.Items.Strings [grpOutputLevel.ItemIndex];
if current = '0dB' then level := dB0;
if current = '-3dB' then level := dB3;
if current = '-6dB' then level := dB6;
if current = '-9dB' then level := dB9;
if current = '-12dB' then level := dB12;
if current = '-15dB' then level := dB15;
if current = '-18dB' then level := dB18;
if current = '-20dB' then level := dB20;
lblFnow.Caption := current;
sine_table_done := false; // level is different, so throw away present table
restart_sweep;
end;
　
procedure TForm1.restart_sweep;
begin
if sweep_running then start_sweep;
end;
　
procedure TForm1.stop_sweep;
begin
// is a sweep running? if so, stop it
if sweep_running
then
begin
shutoff := true;
waveOutReset (hWave_out);
sweep_running := false;
closed := false;
repeat
Application.ProcessMessages;
until closed;
end
end;
　
procedure TForm1.start_sweep;
var
open_status: MMRESULT;
code: integer;
begin
if sweep_running then stop_sweep;
// try to convert the text in the edit boxes to numbers
Val (edtF1.Text, f_min, code);
if code <> 0 then f_min := 150;
angle := 0;
// fill in the TWaveFormatEx structure with our wave details
with pcm do
begin
wFormatTag := wave_Format_PCM; // it's PCM data
nChannels := 1; // mono
nSamplesPerSec := sample_rate; // set the 44.1KHz rate
nAvgBytesPerSec := 2 * sample_rate; // two bytes per sample
nBlockAlign := 2; // for mono 16-bit audio
wBitsPerSample := 16; // 16-bit audio
cbSize := 0;
end;
shutoff := false;
// try and open the wave device for our format of wave data
open_status := waveOutOpen (@hWave_out, 0, @pcm, Handle, 0, callback_window);
if open_status = 0
then
begin
// prepare to receive the WaveOutOpen message to sctually start sending data
sweep_running := true;
closed := false;
lblFnow.Caption := IntToStr (f_min) + ' Hz';
lblFnow.Visible := True;
end
else
begin
sweep_running := false;
hWave_out := 0;
// inform user of failure
MessageDlg (open_error + #13#10 + translate_mm_error (open_status),
mtWarning, [mbOK], 0);
end;
end;
　
　
　
procedure TForm1.mm_wom_open (var Msg: tMessage);
// This code handles the WaveOutOpen message by writing two buffers of data
// to the wave device. Plus other miscellaneous housekeeping.
var
chunks: integer;
buffer_fill: integer;
// max valid sample in the buffer
begin
btnStart.Caption := 'STOP'; // first, tell the user how to stop the sound!
if not sine_table_done then do_sine_table; // build sine-wave table if
required
// populate the first wave header
with p_wave_hdr1^ do
begin
lpData := pChar (p_buffer1); // pointer to the data
dwBufferLength := 0; // fill in size later
dwBytesRecorded := 0;
dwUser := 0;
dwFlags := 0;
dwLoops := 1; // just a single loop
lpNext := nil;
reserved := 0;
end;
// populate the second buffer
p_wave_hdr2^ := p_wave_hdr1^; // copy most of the data
p_wave_hdr2^.lpData := pChar (p_buffer2); // except the buffer address!
// compute number of chunks in the sweep, ensure it's at least two
// aim for about four different frequencies per second
chunks := trunc ((sweep_time * sample_rate) / (sample_rate div 4) +
0.999);
if chunks < 2 then chunks := 2;
buffer_fill := (trunc (sweep_time * 2.0 * sample_rate / chunks)) and
$FFFFFFFE;
f := f_min;
p_wave_hdr1^.dwBufferLength := buffer_fill; // actual buffer sizes
p_wave_hdr2^.dwBufferLength := buffer_fill;
buffers_played := 0;
buffers_written := 0;
// now write the first two buffers into the wave output
waveOutPrepareHeader (hWave_out, p_wave_hdr1, SizeOf (TWaveHdr));
write_next_buffer (p_wave_hdr1);
waveOutPrepareHeader (hWave_out, p_wave_hdr2, SizeOf (TWaveHdr));
write_next_buffer (p_wave_hdr2);
end;
　
procedure TForm1.write_next_buffer (header: pWaveHdr);
begin
if shutoff then Exit;
with header^ do
begin
// fill buffer with sinewave data, record the frequency in the user field
fill_buffer_with_sinewave (pBuffer (lpData), 0, dwBufferLength div 2);
dwUser := round (f);
end;
// last_f := f;
// write the buffer and bump the number written
waveOutWrite (hWave_out, header, SizeOf (TWaveHdr));
Inc (buffers_written);
all_written := False
end;
　
procedure TForm1.mm_wom_done (var Msg: tMessage);
// handle the wave out done message by writing the next buffer, if required
var
free_header: pWaveHdr;
begin
// note the fact that another buffer has been completed
Inc (buffers_played);
// point to wave header just completed, i.e. the next free buffer
free_header := pWaveHdr (msg.lParam);
if not shutoff then
begin
if (all_written) or (buffers_played >= buffers_written)
then
begin
// everything written has been played
shutoff := true;
sweep_running := false;
closing := false; // say we're not closing just yet
end
else
begin
// make a note of the last frequency for the user
lblFnow.Caption := Format ('%.0f Hz', [f]);
// and write the next buffer, re-using the one just played
write_next_buffer (free_header);
end;
end;
if shutoff then
begin
waveOutReset (hWave_out);
waveOutClose (hWave_out);
end;
end;
　
procedure TForm1.mm_wom_close (var Msg: tMessage);
// handle the wave out close message, release the wave headers
begin
waveOutUnprepareHeader (hWave_out, p_wave_hdr1, SizeOf (TWaveHdr));
waveOutUnprepareHeader (hWave_out, p_wave_hdr2, SizeOf (TWaveHdr));
p_wave_hdr1 := pWaveHdr (GlobalLock (hWave_hdr1));
if p_wave_hdr1 = nil then
ShowMessage ('Failed to re-lock buffer p_wave_hdr1!');
p_wave_hdr2 := pWaveHdr (GlobalLock (hWave_hdr2));
if p_wave_hdr2 = nil then
ShowMessage ('Failed to re-lock buffer p_wave_hdr2!');
lblFnow.Visible := False;
btnStart.Caption := 'Start';
hWave_out := 0;
closed := true;
if closing then Close;
end;
　
procedure TForm1.do_sine_table;
var
i: 0..sine_table_samples - 1;
y, magnitude: extended;
begin
if sine_table_done then Exit; // nothing to do
// convert dB to a mathematical fraction of full amplitude
case level of
dB0: magnitude := 1.0;
dB3: magnitude := 0.707;
dB6: magnitude := 0.5;
dB9: magnitude := 0.354;
dB12: magnitude := 0.25;
dB15: magnitude := 0.177;
dB18: magnitude := 0.125;
dB20: magnitude := 0.1;
else
magnitude := 0.25; // should never be here, but just in case.....
end;
// yes, I realise we could symmetry to reduce the number of computations
// required, but it really doesn't take that long.
for i := 0 to sine_table_samples - 1 do
begin
// Assume 16-bit audio goes from -32767..32767, avoids clipping.
// There are only 2^15 samples here, this simplfies the subsequent angle
// calculation but might restrict the dynamic range produced with noise
// sidebands. However, in the quality of equipment likely to be
// encountered this won't matter. You've got the source code, so
// you can alter this if you like.
y := round (magnitude * (32767.0 * sin (2.0* i * Pi / sine_table_samples)));
sine_table^ := round ;
end;
sine_table_done := true;
end;
　
procedure TForm1.fill_buffer_with_sinewave (bfr: pBuffer; index, samples:
integer);
const
fract_bits = 15;
var
sample: integer;
d_angle: integer; // 32-bit number, with 14 fractional bits, i.e. 17.15
max_angle: integer;
w: audio_sample;
begin
// compute the angular step per sample corresponding to the desired frequency
d_angle := round ((sine_table_samples shl fract_bits) * f / sample_rate);
// this is the maximum number of samples in the sine table
max_angle := (sine_table_samples shl fract_bits) - 1;
for sample := 0 to samples - 1 do
begin
w := sine_table^ [angle shr fract_bits]; // get current sine value
bfr^ [index] := w; // store it in the caller's
buffer
Inc (index); // bump the buffer pointer
Inc (angle, d_angle); // bump the angle
angle := angle and max_angle; // wrap to 360 degrees
end;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
stop_sweep;
shutoff := true;
end;
　
procedure TForm1.edtF1Change(Sender: TObject);
begin
f:=strtoint(edtf1.Text);
end;
procedure TForm1.btnStartClick(Sender: TObject);
begin
{is a sweep running? if so, stop it}
if sweep_running
then stop_sweep
else start_sweep;
end;
end.
　
　
nNn
bqq:2080 sSs | bBb
____________________-_-|_/__/____
| 我爱编程 xcejian&163.com |
------------------------------------
_/_/_/_/ 梦想让人飞翔
_/_/_/_/ 深蓝之波 snb
_/_/_/_/ 2001-07-22
_/_/_/_/_/_/_/_/