unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Forms,
 Dialogs, MMSystem, ScktComp, MSACM, ExtCtrls, zlibex, Controls, StdCtrls;

type
 TWavArrayBuf = array[0..1023]of byte;
 PWavArrayBuf = ^TWavArrayBuf;

 TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
 private
   procedure WndProc(var Msg: TMessage); override;
   function InitWaveIn: Boolean;
   procedure CloseWaveIn;
 end;

var
 Form1: TForm1;
 WaveHdr: PWaveHdr;
 WavBuff: PWavArrayBuf;
 WaveIn: PHWaveIn;

implementation

uses Math;

{$R *.dfm}

function TForm1.InitWaveIn: Boolean;
var
 I, Err: Integer;

maxsizeformat,res:longint;
   WaveFormat: TWaveFormatEx;

 procedure FreeData;
 begin
   if WavBuff <> nil then Dispose(WavBuff);
   if WaveHdr <> nil then Dispose(WaveHdr);
   if WaveIn <> nil then Dispose(WaveIn);
 end;

begin
 Result := False;
 WaveFormat.wFormatTag := WAVE_FORMAT_PCM; //здесь нужно поставить GSM6.10 (вроде бы $31)
 WaveFormat.nChannels := 1;
 WaveFormat.nSamplesPerSec := 8000;
 WaveFormat.nAvgBytesPerSec := 8000;
 WaveFormat.nBlockAlign := 1;
 WaveFormat.wBitsPerSample := 8;

 WaveIn := New(PHWaveIn);
 Err := WaveInOpen(WaveIn, 0, @WaveFormat, Handle, 0, CALLBACK_WINDOW or WAVE_MAPPED);
 if Err <> 0 then
 begin
 Application.MessageBox(PChar('Error: '+IntToStr(Err)+': '+SysErrorMessage(GetLastError)),'Error',0);
 Exit;
 end;
 for i:=1 to 8 do
 begin
   WavBuff := New(PWavArrayBuf);
   WaveHdr := New(PWaveHdr);
   with WaveHdr^ do
   begin
     lpData := Pointer(WavBuff);
     dwBufferLength := SizeOf(WavBuff);
     dwBytesRecorded := 0;
     dwUser := 0;
     dwFlags := 0;
     dwLoops := 0;
   end;
   Err := WaveInPrepareHeader(WaveIn^, WaveHdr, SizeOf(TWaveHdr));
   if Err <> 0 then
   begin
 Application.MessageBox(PChar('Error: '+IntToStr(Err)+': '+SysErrorMessage(GetLastError)),'Error',0);
     FreeData;
     Exit;
   end;
   Err := WaveInAddBuffer(WaveIn^, WaveHdr, Sizeof(TWaveHdr));
   if Err <> 0 then
   begin
 Application.MessageBox(PChar('Error: '+IntToStr(Err)+': '+SysErrorMessage(GetLastError)),'Error',0);
     FreeData;
     Exit;
   end;
 end;
 Err := WaveInStart(WaveIn^);
 if Err <> 0 then
 begin
 Application.MessageBox(PChar('Error: '+IntToStr(Err)+': '+SysErrorMessage(GetLastError)),'Error',0);
   FreeData;
   Exit;
 end;
 Result := True;
end;

Procedure Tform1.WndProc(var Msg: TMessage);
var
 Hdr: PWaveHdr;
 I: Integer;
 R: Real;
begin
 inherited;
 case Msg.Msg of
   MM_WIM_DATA:
   begin
     Hdr := PWaveHdr(Msg.LParam);
     if Hdr^.dwBytesRecorded = 0 then Exit;
     R := IfThen(Hdr^.dwBytesRecorded > 0,
       ClientWidth / Hdr^.dwBytesRecorded, 0);
     PatBlt(Canvas.Handle, 0, 0, ClientWidth,  ClientHeight, PATCOPY);
     Canvas.Pen.Color:=clRed;
     Canvas.MoveTo(0, 127);
     Canvas.LineTo(ClientWidth, 127);
     Canvas.Pen.Color := clMaroon;
     for I := 1 to 12 do
     begin
       Canvas.MoveTo(Round(R * (I * 100)), 0);
       Canvas.LineTo(Round(R * (I * 100)), 255);
     end;
     Canvas.Pen.Color:=clLime;
     Canvas.MoveTo(0, PWavArrayBuf(Hdr.lpData)^[0]);

     for I := 0 to Hdr^.dwBytesRecorded - 1 do
       Canvas.LineTo(Round(R * I), PWavArrayBuf(Hdr.lpData)^[I]);

     WaveInUnprepareHeader(WaveIn^, Hdr, Sizeof(TWaveHdr));
     Dispose(hdr.lpData);
     DisPose(hdr);

     Hdr := New(PWaveHdr);
     Hdr^.lpData := Pointer(New(PWavArrayBuf));
     Hdr^.dwBufferLength := 1024;
     Hdr^.dwBytesRecorded := 0;
     Hdr^.dwUser := 0;
     Hdr^.dwFlags := 0;
     Hdr^.dwLoops := 0;

     WaveInPrepareHeader(WaveIn^, Hdr, Sizeof(TWaveHdr));
     WaveInAddBuffer(WaveIn^, Hdr, Sizeof(TWaveHdr));
   end;
 end;
end;

procedure TForm1.CloseWaveIn;
begin
 WaveInStop(WaveIn^);
 if WaveIn <> nil then
 begin
   WaveInReset(WaveIn^);
   WaveInClose(WaveIn^);
 end;
 Dispose(WaveIn);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 DoubleBuffered := True;
 Height := 282;
 Width := 1000;
 Color := clBlack;
 if not InitWaveIn then ShowMessage(SysErrorMessage(GetLastError));
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 CloseWaveIn;
end;

end.