用声卡发声

Tags: /超级猛料/Multi-Media.多媒体相关/ Date Created:

用声卡发声

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;

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;

if shutoff then

begin

waveOutReset (hWave_out);

waveOutClose (hWave_out);

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^ [i] := round (y);

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;

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

_/_/_/_/_/_/_/_/