fft.~pas

音频FFT

unit fft;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,audio,
  StdCtrls, ExtCtrls;
const cd=1024;
type
  Tfftform = class(TForm)
    Panel1: TPanel;
    PaintBox1: TPaintBox;
    GroupBox1: TGroupBox;
    Button1: TButton;
    Timer1: TTimer;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    Label1: TLabel;
    Label2: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
  { Private declarations }
    procedure Audio1Record(Sender: TObject; LP,RP: Pointer;
                            BufferSize: Word);
    procedure qsj;
    procedure ht;
  public
    pstr:array of byte;
    yszb: array[0..cd] of tpoint;
    fftzb:array[0..cd] of tpoint;
    pr:   array[0..cd] of double;
    pi:   array[0..cd] of double;
    fr:   array[0..cd] of double;
    fi:   array[0..cd] of double;
    { Public declarations }
  end;

var
  fftform: Tfftform;
  audio1:taudio;
  LeftStream,RightStream:TMemoryStream;
  pstr:array of short;
  p:integer;
implementation

procedure kkfft(var pr: array of double; var pi: array of double; n: integer; k: integer;var fr: array of double; var fi: array of double; l: integer;il: integer);stdcall;external'fft.dll';
{$R *.DFM}

procedure Tfftform.FormCreate(Sender: TObject);
begin
    audio1:=taudio.create(self);         //初始化声卡
    audio1.OnRecord:=audio1record;
    Audio1.Recorder.Triggered:=false;
    if not (Audio1.Recorder.Start) then showmessage('Audio1.ErrorMessage');
    if LeftStream <> nil then begin
      LeftStream.Free; RightStream.Free;
      LeftStream := nil; RightStream:=nil;
    end;
    try
      LeftStream :=TMemoryStream.Create;
      RightStream:=TMemoryStream.Create;
    except
      LeftStream:=nil; RightStream:=nil;
      if not (Audio1.Recorder.Stop) then showmessage('Audio1.ErrorMessage');
      exit;
    end;
end;
procedure Tfftform.Audio1Record(Sender: TObject; LP,RP: Pointer;
  BufferSize: Word);
begin
  if BufferSize>0 then
  begin
    setlength(pstr,buffersize);
    move(lp^,pstr[0],buffersize);
  end;
end;
procedure Tfftform.Button1Click(Sender: TObject);
begin
  if button1.Caption='开始' then
    begin
      timer1.Enabled:=true;
      button1.Caption:='暂停';
    end else
    begin
      timer1.Enabled:=true;
      button1.Caption:='开始';
    end;
end;

procedure Tfftform.Timer1Timer(Sender: TObject);
begin
  qsj;
  kkfft(pr,pi,cd,10,fr,fi,0,1);
  ht;
end;
procedure tfftform.qsj;
begin
  for p:=0 to cd do
    begin
      pr[p]:=pstr[p];
      pi[p]:=0;
    end;
end;
procedure tfftform.ht;
begin
  for p:=0 to cd do
    begin
      yszb[p].y:=250-round(pstr[p]/1);
      yszb[p].x:=p;
      fftzb[p].y:=350-round(pr[p]/50);
      fftzb[p].x:=p;
    end;
    fftzb[0]:=fftzb[6];
    fftzb[1]:=fftzb[6];
    fftzb[2]:=fftzb[6];
    fftzb[3]:=fftzb[6];
    fftzb[4]:=fftzb[6];
   paintbox1.Repaint;
   if checkbox1.Checked then
   begin
     paintbox1.Canvas.pen.Color:=clblue;
     paintbox1.Canvas.Polyline(yszb);
   end;
   if checkbox2.Checked then
   begin
     paintbox1.Canvas.pen.Color:=clred;
     paintbox1.Canvas.Polyline(fftzb);
   end;
end;
end.