unit UThreadCapture;
interface
uses
Classes, SysUtils, Windows, Messages, MMSystem;
type
T24Bit =
packed record
Lo: Byte;
Hi: SmallInt;
end;
type
TCapBuffer=
array of char;
TCapBuffers=
array of TCapBuffer;
type
T_Capturesettings=Record
Device: integer;
//capture device number
SampleRate: integer;
//in samples per second
Resolution: integer;
//8,16,24 bit
Channels: integer;
//2=stereo
BufSize: integer;
//buffer size in (stereo) samples
NumBufs: integer;
//cyclic reuse if >0
Receiver: hwnd;
//handle of Window which has sent the capture request
ReturnMsg: integer;
//message to be sent to receiver handle upon available data
end;
Type
tWAVEFORMATEX =
packed record
wFormatTag: Word;
{ format type }
nChannels: Word;
{ number of channels (i.e. mono, stereo, etc.) }
nSamplesPerSec: DWORD;
{ sample rate }
nAvgBytesPerSec: DWORD;
{ for buffer estimation }
nBlockAlign: Word;
{ block size of data }
wBitsPerSample: Word;
{ number of bits per sample of mono data }
cbSize: Word;
{ the count in bytes of the size of }
end;
type
TSamples =
packed record
case word
of
0: (wValidBitsPerSample: word);
// bits of precision
1: (wSamplesPerBlock: word);
// valid if wBitsPerSample = 0
2: (wReserved: word);
// If neither applies, set to zero.
end;
PWAVEFORMATEXTENSIBLE = ^tWAVEFORMATEXTENSIBLE;
tWAVEFORMATEXTENSIBLE =
packed record
Format: tWAVEFORMATEX;
Samples: TSamples;
dwChannelMask: longword;
// which channels are present in stream
SubFormat: TGUID;
end;
const
WAVE_FORMAT_EXTENSIBLE = $FFFE;
// Microsoft ksmedia.h
KSDATAFORMAT_SUBTYPE_PCM: TGUID = '
{00000001-0000-0010-8000-00aa00389b71}';
// Microsoft ksmedia.h
type
TCapture =
class(TThread)
private
{ Private declarations }
Fwnd: HWND;
Cap: T_Capturesettings;
CapBuf: TCapBuffer;
Granularity: integer;
ByteBufSize: integer;
BufNum: integer;
logging: boolean;
WaveInHandle : hWaveIn;
// Handle to soundcard
WaveHdr :
array of TWaveHdr;
// Pointer to API communication block
procedure WndProc(
var Msg:TMessage);
Procedure MMInDone (
Var Msg : Tmessage);
Message MM_WIM_DATA;
function StartCapture: boolean;
// Audio functions
Function LogInit (CallBack : THandle; DeviceID, SampleRate,
BitsPerSample, Channels : Integer ): boolean;
Procedure LogClose;
Function LogStart (PBuffer : Pointer; BufferSz : Cardinal; NBuf: integer): TLargeInteger;
Function LogStop: boolean;
Function LogRequeueBuffer(i: integer): boolean;
Function LogAddBuffer (PBuffer : Pointer; BufferSz : Cardinal; i: integer): boolean;
Function LoggedBytes: cardinal;
Function LogCapabilities(Device: integer):
string;
protected
procedure Execute;
override;
public
CapBuffers: TCapBuffers;
procedure ClearBuffer(i: integer);
procedure ClearBuffers;
function StereoSample(
var L,R: integer; n: integer): boolean;
procedure Terminate;
reintroduce;
constructor Create(Capture: T_Capturesettings;ThreadPriority: TThreadPriority);
published
end;
implementation
function TCapture.StereoSample(
var L,R: integer; n: integer): boolean;
var
n0,ni,nf: integer;
x8:
array[0..5]
of char;
x24:
array [0..1]
of T24Bit
absolute x8;
x16:
array [0..1]
of SmallInt
absolute x8;
i: integer;
begin
result:=false;
if Cap.Channels<>2
then exit;
n0:=length(CapBuffers);
ni:=n
div Cap.BufSize;
nf:=n-ni*Cap.BufSize;
if ni>=n0
then exit;
for i:=0
to Granularity-1
do
x8[i]:=CapBuffers[ni][nf*Granularity+i];
case Cap.Resolution
of
8:
begin
L:=byte(x8[0])-128;
R:=byte(x8[1])-128;
end;
16:
begin
L:=x16[0];
R:=x16[1];
end;
24:
begin
L:=x24[0].Lo+x24[0].Hi*256;
R:=x24[1].Lo+x24[1].Hi*256;
end;
end;
result:=true;
//if length(CapBuffers)>i then SetLength(CapBuffers[i],0);
end;
procedure TCapture.ClearBuffer(i: integer);
begin
if length(CapBuffers)>i
then SetLength(CapBuffers[i],0);
end;
procedure TCapture.ClearBuffers;
var i: integer;
begin
if not logging
then
for i:=0
to length(CapBuffers)-1
do
ClearBuffer(i);
SetLength(CapBuffers,0);
end;
{ Important: Methods and properties of objects in VCL or CLX can only be used
in a method called using Synchronize}
constructor TCapture.Create(Capture: T_Capturesettings;ThreadPriority: TThreadPriority);
begin
inherited Create(true);
Priority := ThreadPriority;
WaveInHandle:=0;
Cap:=Capture;
Granularity:=Cap.Channels*Cap.Resolution
div 8;
ByteBufSize:=Cap.BufSize*Granularity;
SetLength(CapBuf,Cap.NumBufs*ByteBufSize);
Suspended:=false;
end;
procedure TCapture.Terminate;
begin
inherited Terminate;
LogClose;
PostMessage(Fwnd, WM_QUIT , 0,0);
end;
{ TCapture }
Procedure TCapture.MMInDone (
Var Msg : Tmessage);
var
n,nb: integer;
Begin
if Logging
then
begin
n:=Length(CapBuffers);
SetLength(CapBuffers,n+1);
SetLength(CapBuffers[n],ByteBufSize);
move(CapBuf[BufNum*ByteBufSize],CapBuffers[n][0],ByteBufSize);
LogRequeueBuffer(BufNum);
BufNum:=(BufNum+1)
mod Cap.NumBufs;
end
else
begin
LogStop;
LogClose;
end;
end;
function TCapture.StartCapture: boolean;
var
LogOk: boolean;
begin
Result:=false;
BufNum:=0;
Logging:=true;
LogOK:=LogInit (Fwnd, Cap.Device, Cap.SampleRate, Cap.Resolution, Cap.Channels);
//Win Message
if LogOK
then LogStart (CapBuf, ByteBufSize ,Cap.NumBufs);
Result:=LogOK
end;
//main thread procedure
procedure TCapture.Execute;
var msg:Tmsg;
begin
Fwnd:=allocatehwnd(WndProc);
//hier ist jetzt dein Windowhandle für MMAudio
try
StartCapture;
while getMessage(msg,0,0,0)
do //warten auf Message
DispatchMessage(msg);
//verteilen auf das entsprechende Fenster (gibt hier allerdings eh nur eins)
finally
Deallocatehwnd(Fwnd);
end;
logging:=false;
SetLength(CapBuf,0);
end;
procedure TCapture.WndProc(
var Msg:TMessage);
begin
dispatch(msg);
end;
//////MMAudio Functions
Function TCapture.LogCapabilities(Device: integer):
string;
var
WaveInCaps: TWaveInCaps;
begin
if waveInGetDevCaps(Device, @WaveInCaps,SizeOf(WaveInCaps)) = 0
then
Result:=WaveInCaps.szPname
else
Result:='
not available';
end;
Function TCapture.LoggedBytes: cardinal;
var
TimeInfo: TMMTime;
begin
If WaveInHandle = 0
Then
begin
Result:=0;
exit;
end;
TimeInfo.wType:=TIME_BYTES;
if WaveInGetPosition(WaveInHandle,@TimeInfo,SizeOf(TimeInfo)) <> 0
then
Raise
Exception.Create ('
Error retrieving capture position.')
else result:=TimeInfo.sample;
end;
Function TCapture.LogInit (CallBack : THandle; DeviceID, SampleRate,
BitsPerSample, Channels : Integer ): boolean;
(* Setup of soundcard input *)
Var
WaveFormat : tWAVEFORMATEXTENSIBLE;
Begin
Result:=true;
With WaveFormat
Do
Begin;
With Format
Do
Begin
If BitsPerSample < 17
then WFormatTag := WAVE_FORMAT_PCM
else WFormatTag := WAVE_FORMAT_EXTENSIBLE;
NChannels := Channels;
NSamplesPerSec := SampleRate;
NAvgBytesPerSec := SampleRate*Channels*BitsPerSample
div 8;
NBlockAlign := Channels*BitsPerSample
div 8;
wBitsPerSample := BitsPerSample;
cbSize := 22;
End;
With Samples
Do
Begin
wValidBitsPerSample := BitsPerSample;
wSamplesPerBlock := 1;
wReserved := 0;
End;
dwChannelMask := 3;
//front left and right speaker
SubFormat := KSDATAFORMAT_SUBTYPE_PCM;
End;
Try
If WaveInOpen (
Nil, DeviceID, @WaveFormat, 0, 0,
WAVE_FORMAT_QUERY) <> 0
Then Result:=false;
//Raise Exception.Create ('Requested format not supported.');
If WaveInOpen (@WaveInHandle, DeviceID, @WaveFormat,
CallBack, 0, CALLBACK_WINDOW) <> 0
Then Result:=false;
//Raise Exception.Create ('No handle to sound card.');
Except Result:=false;
end;
End;
Procedure TCapture.LogClose;
(* Close connection with sound card *)
Begin
If WaveInHandle <> 0
Then
Begin
WaveInClose (WaveInHandle);
WaveInHandle := 0
End;
End;
Function TCapture.LogRequeueBuffer(i: integer): boolean;
(* ReQueue i.th Buffer to soundcard. *)
Begin
If WaveInPrepareHeader (WaveInHandle, @WaveHdr[i],
SizeOf (WaveHdr[i])) <> 0
Then
Raise Exception.Create ('
In Prepare error');
If WaveInAddBuffer (WaveInHandle, @WaveHdr[i],
sizeof (WaveHdr[i])) <> 0
Then
begin
Raise Exception.Create ('
Add buffer error');
end;
End;
Function TCapture.LogAddBuffer (PBuffer : Pointer; BufferSz : Cardinal; i: integer): boolean;
(* Add a new buffer *)
Begin
Result:=true;
SetLength(WaveHdr,i+1);
// Initialization of API communication block
With WaveHdr[i]
Do
Begin
lpdata := PBuffer;
dwbufferlength := BufferSz;
dwbytesrecorded := 0;
dwUser := 0;
dwflags := 0;
dwloops := 0;
lpNext :=
Nil;
reserved := 0;
End;
If WaveInPrepareHeader (WaveInHandle, @WaveHdr[i],
SizeOf (WaveHdr[i])) <> 0
Then
Raise Exception.Create ('
In Prepare error');
If WaveInAddBuffer (WaveInHandle, @WaveHdr[i],
sizeof (WaveHdr[i])) <> 0
Then
Raise Exception.Create ('
Add buffer error');
End;
Function TCapture.LogStart (PBuffer : Pointer; BufferSz : Cardinal; NBuf: integer): TLargeInteger;
(* Start logging of soundcard data. *)
var i:integer;
t:TLargeInteger;
Begin
SetLength(WaveHdr,NBuf);
for i:=0
to NBuf-1
do
begin
// Initialization of API communication block
With WaveHdr[i]
Do
Begin
lpdata := PBuffer;
dwbufferlength := BufferSz;
dwbytesrecorded := 0;
dwUser := 0;
dwflags := 0;
dwloops := 0;
lpNext :=
Nil;
reserved := 0;
End;
If WaveInPrepareHeader (WaveInHandle, @WaveHdr[i],
SizeOf (WaveHdr[i])) <> 0
Then
Raise Exception.Create ('
In Prepare error');
If WaveInAddBuffer (WaveInHandle, @WaveHdr[i],
sizeof (WaveHdr[i])) <> 0
Then
Raise Exception.Create ('
Add buffer error');
If WaveInStart (WaveInHandle) <> 0
Then
Raise Exception.Create ('
Error in starting logger');
if i=0
then QueryPerformanceCounter(t);
PBuffer:=Pointer(Cardinal(PBuffer)+BufferSz);
End;
//BufferHeaderLoop
Result:=t;
End;
Function TCapture.LogStop: boolean;
//Stop recording
var i:integer;
Begin
Result:=true;
If WaveInHandle <> 0
then
begin
WaveInReset(WaveInHandle);
//mark all buffers as done
For i:=0
to Length(WaveHdr)-1
do //unprepare all buffers
If WaveInUnPrepareHeader (WaveInHandle, @WaveHdr[i], sizeof (TWavehdr)) <> 0
Then Raise Exception.Create ('
Error in UnPrepare Capture Buffers');
//result=33 => still playing
SetLength(WaveHdr,0);
end;
End;
end.